如何提高部分匹配查找功能的性能？

Question

此功能的当前性能是慢，目前我正在使用sheet1上的500多个项目代码列表。 该函数在sheet2上的200 000 +项目范围内搜索，以查找包括部分匹配在内的所有匹配项。 这意味着我们在查找条件之前和之后包含通配符以查找所有匹配项。

目前完成需要15分钟。 有没有更好的方法来做到这一点？ 要在5分钟内得到这个？

Function ConcatIf(ByVal compareRange As Range, ByVal xCriteria As Variant, _
                        Optional ByVal stringsRange As Range, Optional Delimiter As String) As String

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False

    Dim i As Long, j As Long, criteriaMet As Boolean

    Set compareRange = Application.Intersect(compareRange, _
                    compareRange.Parent.UsedRange)

    If compareRange Is Nothing Then Exit Function
    If stringsRange Is Nothing Then Set stringsRange = compareRange
    Set stringsRange = compareRange.Offset(stringsRange.Row - _ 
    compareRange.Row, stringsRange.Column - compareRange.Column)

        For i = 1 To compareRange.Rows.Count
            For j = 1 To compareRange.Columns.Count
               If (Application.CountIf(compareRange.Cells(i, j), _ 
    xCriteria)= 1) Then
                    ConcatIf = ConcatIf & Delimiter & _
    CStr(stringsRange.Cells(i, j))
                End If

            Next j
        Next i
        ConcatIf = Mid(ConcatIf, Len(Delimiter) + 1)

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True

End Function

例：

+500项目代码

Sheet1:  

BCD  
CDF  
XLMH  
XPT  
ZPY  

20万+全部项目代码

Sheet2:  

FDBCDGH  
HSGDBCDSU  
GFD-CDFGDTR  
SBGCDFHUD  
GKJYCDFFDS  
DDFGFDXLMHGFD  
SDGXLMHSDFS  
SDGVSDXLMHFAMN  
DDDSXPTDFGFD  
JUYXPTFADS  
DDDFFZPYDGDFDF  

结果应该是：

工作表Sheet1：

COLUMN A - COLUMN B  
BCD - FDBCDGH,HSGDBCDSU  
CDF - GFD-CDFGDTR,SBGCDFHUD,GKJYCDFFDS  
XLMH - DDFGFDXLMHGFD,SDGXLMHSDFS,SDGVSDXLMHFAMN  
XPT - DDDSXPTDFGFD,JUYXPTFADS  
ZPY - DDDFFZPYDGDFDF  

Answer 1

要使用以下代码，您需要添加对Microsoft Scripting Runtime的引用。 这使用两个数组并在字典中编译数据。 然后可以将其写回您的工作表。 代码当前将结果写回到即时窗口，可以使用Ctrl + G或View - > Immediate Window

Public Sub demo()
    Dim compArr As Variant, strArr As Variant
    Dim strDict As Dictionary
    Dim i As Long
    Dim Delimiter As String: Delimiter = "; "
    Dim key

    ' Set data to arrays. This assumes your data is in column A
    With Sheets("Sheet1")
        ' Application.Transpose is a trick to convert the range to a 1D array (otherwise a 2D array will be created)
        compArr = Application.Transpose(.Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)))
    End With
    With Sheets("Sheet2")
        strArr = Application.Transpose(.Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)))
    End With

    ' Initiate dictionary
    Set strDict = New Dictionary

    ' Loop through all the values you wish to find
    For i = LBound(compArr) To UBound(compArr)
        ' Tests if value exists
        If Not strDict.Exists(compArr(i)) Then
            ' Adds value to dictionary and uses filter on string array to get similar matches.
            ' Join is used to convert the resulting array into a string
            strDict.Add key:=compArr(i), Item:=Join(Filter(strArr, compArr(i), True), Delimiter)
        End If
    Next i

    ' Read back results
    For Each key In strDict.Keys
        Debug.Print key, strDict(key)
    Next key
End Sub

Answer 2

要保持关于数据集大小的所有当前功能和可用性，这应该适合您并且比原始代码更快。 当我计时时，我使用了400,000个完整项目代码，并在表单1上应用了concatif公式，进行了1000次部分匹配，并在9分钟内完成了所有单元格计算。

Public Function CONCATIF(ByVal arg_rCompare As Range, _
                         ByVal arg_vCriteria As Variant, _
                         Optional ByVal arg_rStrings As Range, _
                         Optional ByVal arg_sDelimiter As String = vbNullString _
  ) As Variant

    Dim aData As Variant
    Dim aStrings As Variant
    Dim aCriteria As Variant
    Dim vString As Variant
    Dim vCriteria As Variant
    Dim aResults() As String
    Dim ixResult As Long
    Dim i As Long, j As Long

    If arg_rStrings Is Nothing Then Set arg_rStrings = arg_rCompare
    If arg_rStrings.Rows.Count <> arg_rCompare.Rows.Count _
    Or arg_rStrings.Columns.Count <> arg_rCompare.Columns.Count Then
        CONCATIF = CVErr(xlErrRef)
        Exit Function
    End If

    If arg_rCompare.Cells.Count = 1 Then
        ReDim aData(1 To 1, 1 To 1)
        aData(1, 1) = arg_rCompare.Value
    Else
        aData = arg_rCompare.Value
    End If

    If arg_rStrings.Cells.Count = 1 Then
        ReDim aStrings(1 To 1, 1 To 1)
        aStrings(1, 1) = arg_rStrings.Value
    Else
        aStrings = arg_rStrings.Value
    End If

    If IsArray(arg_vCriteria) Then
        aCriteria = arg_vCriteria
    ElseIf TypeName(arg_vCriteria) = "Range" Then
        If arg_vCriteria.Cells.Count = 1 Then
            ReDim aCriteria(1 To 1)
            aCriteria(1) = arg_vCriteria.Value
        Else
            aCriteria = arg_vCriteria.Value
        End If
    Else
        ReDim aCriteria(1 To 1)
        aCriteria(1) = arg_vCriteria
    End If

    ReDim aResults(1 To arg_rCompare.Cells.Count)
    ixResult = 0
    For i = LBound(aData, 1) To UBound(aData, 1)
        For j = LBound(aData, 2) To UBound(aData, 2)
            For Each vCriteria In aCriteria
                If aData(i, j) Like vCriteria Then
                    ixResult = ixResult + 1
                    aResults(ixResult) = aStrings(i, j)
                End If
            Next vCriteria
        Next j
    Next i

    If ixResult > 0 Then
        ReDim Preserve aResults(1 To ixResult)
        CONCATIF = Join(aResults, arg_sDelimiter)
    Else
        CONCATIF = vbNullString
    End If

    Erase aData:        aData = vbNullString
    Erase aCriteria:    aCriteria = vbNullString
    Erase aResults

End Function