vba - 在 Excel 中返​​回多个匹配值的最快方法

Question

我正在尝试查看是否有一个宏可以加速我在文件中使用的多重匹配公式。

公式为:

=IFERROR(INDEX(Data!$D:$D,SMALL(IF('Department 1'!$A$1=Data!$B:$B,ROW(Data!$B:$B)-MIN(ROW(Data!$B:$B))+1,""), ROW(Data!A1))),"Enter New Client Name")

在工作簿中，有三个工作表:数据、部门 1 和部门 2。

在“数据”工作表中，B 列列出了所有部门(即部门 1 和部门 2)，C 列列出了属于每个部门的客户。

部门 1 和部门 2 工作表具有完全匹配公式，该公式根据部门名称查找客户列表。

即使我只是查找 10 个客户，这个公式运行速度也很慢，所以我想知道是否可以使用宏来加速它？

我检查了这个网站，发现可以立即查找 40,000 个条目(见下文)，但它只在一个工作表上运行宏。我正在使用的真实工作簿有 30 多个不同的部门，我需要在所有 30 个工作表上运行该公式，以便客户列表对部门来说是唯一的。

如果说明不清楚，我提前道歉，我希望我可以上传一个示例文件，但由于我是新来的，我没有看到上传的选项。任何帮助是极大的赞赏!

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim wb As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim vLoookupVal As Variant
    Dim vValues As Variant
    Dim aResults() As Variant
    Dim lResultCount As Long
    Dim i As Long
    Dim lIndex As Long

    Set wb = ActiveWorkbook
    Set ws1 = Me                    'This is the sheet that contains the lookup value
    Set ws2 = wb.Sheets("Sheet2")   'This is the sheet that contains the table of values

    Application.EnableEvents = False

    If Not Intersect(Target, ws1.Range("A1")) Is Nothing Then
        ws1.Columns("B").ClearContents   'Clear previous results
        vLoookupVal = Intersect(Target, ws1.Range("A1")).Value
        lResultCount = WorksheetFunction.CountIf(ws2.Columns("A"), Target.Value)
        If lResultCount = 0 Then
            MsgBox "No matches found for [" & vLoookupVal & "]", , "No Matches"
        Else
            ReDim aResults(1 To lResultCount, 1 To 1)
            lIndex = 0
            vValues = ws2.Range("A1:B" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row).Value
            For i = LBound(vValues, 1) To UBound(vValues, 1)
                If vValues(i, 1) = vLoookupVal Then
                    lIndex = lIndex + 1
                    aResults(lIndex, 1) = vValues(i, 2)
                End If
            Next i
            ws1.Range("B1").Resize(lResultCount).Value = aResults
        End If
    End If

    Application.EnableEvents = True

End Sub

Answer 1

如果我理解正确，您希望将客户名称分配给他们所属的部门表。

如果部门表不存在，下面的代码将添加部门表，因此您不必担心添加部门表。

假设您的部门名称在工作表“数据”列 B 中，客户名称在工作表“数据”列 C 中，并且它们都有一个标题(您的数据从第二行开始)，并且所有输入数据都插入到 A 列中部门表:

Sub MyClients()
Dim lastrow As Long
Dim wsname As String
lastrow = Worksheets("Data").Cells(Worksheets("Data").Rows.Count, 2).End(xlUp).Row

Application.ScreenUpdating = False
For i = 2 To lastrow
    wsname = Worksheets("Data").Cells(i, 2).Value
    On Error Resume Next
    Worksheets(wsname).Cells(Worksheets(wsname).Rows.Count, 1).End(xlUp).Offset(1, 0) = Worksheets("Data").Cells(i, 3).Value
    If Err.Number = 9 Then
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = Worksheets("Data").Cells(i, 2).Value
        Worksheets(wsname).Cells(Worksheets(wsname).Rows.Count, 1).End(xlUp).Offset(1, 0) = Worksheets("Data").Cells(i, 3).Value
    End If
Next i
Worksheets("Data").Activate
Application.ScreenUpdating = True
End Sub