根據另一列中的值填充範圍，其中一列基於另一列中的值

Question

Happy hump day all， 我希望能得到一些幫助，我相當確定這個宏有一個簡單的解決方案，但我錯過了一個關鍵因素。

情景：我已經得到了填充用戶窗體的組合框命名的區域，我想允許用戶在此範圍內增加或刪除的選擇，這樣用戶窗體只包含什麼，他們正在努力選擇（對非Excel精明的用戶友好的方式）。有一個「主列表」，其中包含幾十個可供選擇的選擇列表，在列表左側添加了一個雙擊工作表事件，其中添加了一個綠色複選標記，表示該項目已被選中。

目標：從主列表中進行選擇後，我希望用戶那裏是一個複選標記列表的左側點擊一個按鈕，它會運行一個宏來識別和相應的值添加到在下一個可用的行上命名範圍。

問題：我試圖在通過每一個「P」（webdings 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