在Excel

时间:2017-05-16 01:20:00

标签: excel vba excel-vba

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

公式为:

  

=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

1 个答案:

答案 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