如果多行中出现相同的值，则Excel创建下拉列表

Posted 2021-05-05

我有一个代码在第一张纸上循环一个范围，并与第二张纸上的值匹配。如果我看到的匹配是验证A单元格是否仅包含数字，如果它是真的，则从表格2 D col复制并将其放置在右侧的一个单元格。我想要做的是，如果A coll中的值出现不止一次，则需要创建一个下拉列表，以便我可以在从Sheet 2 D coll中检索到的值之间进行选择。

For Each c In w1.Range("D2", w1.Range("D" & Rows.Count).End(xlUp))
FR = Application.Match(c, w2.Columns("A"), 0)
If IsNumeric(FR) Then c.Offset(, 2).Value = w2.Range("D" & FR).Value
Next c

  Dim myList As String, r As Range

下面是我用于在A coll中存在值时创建的其他内容的下拉列表。

myList = "Yes,No"

If w1.Range("A" & Rows.Count).End(xlUp).Address <> "$A$1" Then
    For Each r In w1.Range("A2", w1.Range("A" & Rows.Count).End(xlUp))
        If r.Value <> vbNullString Then
            With r.Offset(, 2).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=myList
            End With
            If r.Offset(, 2).Value = "" Then r.Offset(, 2).Value = "No"
            If r.Offset(, 2).Value = "" Then Split myList, ","
            End If
    Next r
End If

这是一张

这是两张

答案

作为所有“第二张”列相同的值相邻，我将如下（评论中的解释）：

Dim comments As String
With w2 'reference "sheet two"
    With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)) 'reference its column A cells from row 1 (header) down to last not empty one
        For Each c In w1.Range("D2", w1.Range("D" & Rows.Count).End(xlUp)) 'loop through "sheet one" column D cells from row 2 down to last not empty one
            .AutoFilter Field:=1, Criteria1:=c.Value ' filter referenced cells on 1st column with current "sheet one" column D cell content
            Select Case Application.WorksheetFunction.Subtotal(103, .Columns(1)) 'check how many filtered cells
                Case 2 'if only one other than header (always selected)
                    c.Offset(, 2).Value = .Offset(1, 3).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) ' just copy the sheet two column A filtered cell corresponding comment in column F and paste to "sheet one" column F cell corrisponding to current column D cell row
                Case Is > 2 'if more than one other than header (always selected)
                    comments = Join(Application.Transpose(.Offset(1, 3).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Value), ",") 'gather all comments in a string
                    With c.Offset(, 2).Validation 'reference "sheet one" column F cell corresponding to column D current one
                        .Delete
                        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=comments 'add validation list to referenced range
                    End With
            End Select
        Next
    End With
    .AutoFilterMode = False
End With