在Excel中返回多个匹配值的最快方法
我试图看看是否有一个macros可以加快我在文件中使用的多重匹配公式。
公式是：
=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个客户端，所以我想知道是否有可能加快使用macros？
我查了一下这个网站，发现能够立即查找40,000个条目的东西（见下面），但是它只在一个工作表上运行macros。 我工作的真实工作簿有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
如果我正确地理解了你，你想分配客户名称到他们所属的部门表 。
下面的代码将添加部门表，如果他们不存在，所以你不必担心添加部门表。
假设你的部门名称是在“数据”栏B中，客户名称是在“数据”栏C中，它们都有一个头（你的数据从第二行开始），所有input数据被插入到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