我正在尝试查看是否有一个宏可以加速我在文件中使用的多重匹配公式。
公式为:
=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
答案 0 :(得分: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