根據一列中的值填充另一列中的值來填充范圍

Question

祝大家度過愉快的一天，我希望可以從此宏中獲得一些幫助，我可以肯定它有一個簡單的解決方案，但我卻缺少一個關鍵因素。

場景：我有一個填充用戶窗體組合框的命名范圍，我想允許用戶從該范圍添加或刪除選擇，因此用戶窗體僅包含他們正在處理的內容的選擇（以用戶友好的方式非excel精通） 。 有一個“主列表”，其中包含數十種選擇，在列表的左側，我在雙擊時添加了一個工作表事件，其中添加了一個綠色選中標記，指示該項目已選中。

目標：從主列表中進行選擇后，我希望用戶單擊一個按鈕，該按鈕將運行一個宏，以識別列表左側是否存在復選標記，並將相應的值添加到下一個可用列表中的命名范圍中行。

問題：我嘗試遍歷每個“ P”（織帶2的選中標記）並將其值添加到右側在技術上是可行的，但它會將值添加到同一單元格中，導致僅最后一項被選中。

如何遍歷每個“ P”並將其分別添加到一行？

Sub Macro3()
Dim lastrow As Long, ws As Worksheet
Set ws = Sheets("named content")
lastrow = ws.Range("F" & Rows.Count).End(xlUp).Row + 1
Dim c As Range
For Each c In Range("MasterList").Offset(, -1).Cells
    If c = "P" Then
    ws.Range("F" & lastrow).Value = c.Offset(, 1)
      End If
Next c
End Sub

我進行了一些改動，最終都得到相同或相似的結果。 任何幫助將不勝感激！ 同時，我認為在添加復選標記時，我將嘗試添加和刪除每個值，看看效果是否更好。

編輯：全部； UGP完美地回答了我的問題，但認為我會分享我將要使用的解決方法。

原始代碼標識每個檢查的值，並在運行宏時將其添加到該列中，而此工作表事件則通過雙擊在主列表中的值旁邊添加復選標記來將該值添加到命名范圍列中，並且同樣； 刪除復選標記時，從命名范圍列中刪除該值：

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim lastrow As Long, ws As Worksheet
Set ws = Sheets("named content")
lastrow = ws.Range("F" & Rows.Count).End(xlUp).Row + 1
If Not Intersect(Target, Range("MasterList").Offset(, -1)) Is Nothing Then
        Application.EnableEvents = False
        If ActiveCell.Value = "P" Then
            ActiveCell.ClearContents
            For c = lastrow To 3 Step -1
            If ws.Cells(c, 6).Value = ActiveCell.Offset(, 1) Then
            Cells(c, 6).Delete Shift:=xlUp
            End If
            Next

        Else
            ActiveCell.Value = "P"
            ws.Range("F" & lastrow).Value = ActiveCell.Offset(, 1)
        End If
        Cancel = True
    End If
    Application.EnableEvents = True
End Sub

Answer 1

它會將所有內容粘貼在同一行中，因為您沒有使用每個新值來計算lastrow。

Sub Macro3()
Dim lastrow As Long, ws As Worksheet
Set ws = Sheets("named content")
Dim c As Range
For Each c In Range("MasterList").Offset(, -1).Cells
    If c = "P" Then
        lastrow = ws.Range("F" & Rows.Count).End(xlUp).Row + 1
        ws.Range("F" & lastrow).Value = c.Offset(, 1)
    End If
Next c
End Sub

Answer 2

這不是一個確切的解決方法，但可能會讓您朝正確的方向入手。 我假設您的綠色復選標記是形狀。 我不知道它是什么類型的形狀，因此您必須為此更改線條。 我使用“向右箭頭”形狀代替。 它將所有“已檢查的”行號放入一個數組中，然后可以使用該數組從這些行中獲取數據。

Public Sub LoopThroughShapes()
Dim Shape As Shape, myArray() As Variant, arrayCounter As Long

ReDim myArray(1 To 1)
arrayCounter = 1
For Each Shape In ActiveSheet.Shapes
    If InStr(1, Shape.Name, "Right Arrow") <> 0 Then
        Shape.Select
        Debug.Print Shape.Name, Shape.TopLeftCell.Row
        ReDim Preserve myArray(1 To arrayCounter)
        myArray(arrayCounter) = Shape.TopLeftCell.Row
        arrayCounter = arrayCounter + 1
    End If
Next

End Sub