时间戳

首页 > 解决方案 > 返回部分匹配另一个条件的唯一值（Excel VBA）

vba - 返回部分匹配另一个条件的唯一值（Excel VBA）

问题描述

我在 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 新手，我不确定执行此操作的最佳方法 - （我曾考虑删除不匹配的值，这会创建空白，然后删除空白行 - 但是我是担心这会有点矫枉过正并且过程繁重？） - 有没有更简洁的方法来实现这一点？

提前致谢！

编辑：添加了详细信息。

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

唯一值列表如下所示：

 AA01
 AA02
 AA03
 BB02
 BB03
 AA05
 CC01
 CC02
 CC03
 CC05
 BB04

当下拉列表选择了AA我希望列表只返回：

AA01
AA02
AA03
AA05

标签： vbaexcel

解决方案

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

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

推荐阅读