Question

我在sheet1上有一张数据表，其中包含重复项。在工作表2上，我使用“高级过滤器”提取了一个唯一值列表：

lr = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Data").Range("F2:F" & lr).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=NewSh2.Range("B4"), Unique:=True

这很好，但是我希望它只返回部分匹配另一个单元格的值（这是K2中的下拉框- 例如，如果在框中选择了AA，则仅返回以AA开头的值。）

我是VBA的新手，我不确定执行此操作的最佳方法-（我曾考虑过删除不匹配的值，这将创建空白，然后删除空白行-但是我担心这会有点矫kill过正，过程繁重吗？）-是否有更整洁的方法来实现这一目标？

谢谢！

编辑：添加了详细信息。

所以K2的下拉菜单中有AA，BB，CC

唯一值列表如下所示：

 AA01
 AA02
 AA03
 BB02
 BB03
 AA05
 CC01
 CC02
 CC03
 CC05
 BB04

当下拉列表选择 AA 时，我希望列表仅返回：

AA01
AA02
AA03
AA05

Answer 1

这是使用字典的一种方法：

Sub tgr()

    Dim wb As Workbook
    Dim wsData As Worksheet
    Dim NewSh2 As Worksheet
    Dim aFullList As Variant
    Dim hUnqMatches As Object
    Dim sMatch As String
    Dim i As Long

    Set wb = ActiveWorkbook
    Set wsData = wb.Sheets("Data")

    With wsData.Range("F2:F" & wsData.Cells(wsData.Rows.Count, "F").End(xlUp).Row)
        If .Row < 2 Then Exit Sub   'No data
        If .Cells.Count = 1 Then
            ReDim aFullList(1 To 1, 1 To 1)
            aFullList(1, 1) = .Value
        Else
            aFullList = .Value
        End If
    End With

    sMatch = wsData.Range("K2").Value
    Set hUnqMatches = CreateObject("Scripting.Dictionary")

    For i = 1 To UBound(aFullList, 1)
        If Left(aFullList(i, 1), Len(sMatch)) = sMatch Then
            If Not hUnqMatches.Exists(aFullList(i, 1)) Then hUnqMatches.Add aFullList(i, 1), aFullList(i, 1)
        End If
    Next i

    If hUnqMatches.Count > 0 Then
        On Error Resume Next
        Set NewSh2 = wb.Sheets("Sheet2")
        On Error GoTo 0
        If NewSh2 Is Nothing Then
            Set NewSh2 = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
            NewSh2.Name = "Sheet2"
        End If
        NewSh2.Range("B4").Resize(hUnqMatches.Count).Value = Application.Transpose(hUnqMatches.Keys)
    End If

End Sub

Answer 2

您只需将工作表K2中的单元格Data添加为自动过滤条件即可。只需将以下代码添加到您的代码中即可：

Criteria1:= Sheets("Data").Range("K2").value

这与您的代码结合在一起：

lr = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row

Sheets("Data").Range("F2:F" & lr).AdvancedFilter Action:=xlFilterCopy, Criteria1:= Sheets("Data").Range("K2").value CopyToRange:=NewSh2.Range("B4"), Unique:=True

有关一些背景知识，请参见：https://www.thespreadsheetguru.com/blog/2015/2/16/advanced-filters-with-vba-to-automate-filtering-on-and-out-specific-values

返回与另一个条件匹配的唯一值（Excel VBA）

2 个答案: