Как повысить производительность функции поиска частичного совпадения?

Question

Текущая производительность этой функции - медленная, в настоящее время я работаю со списком из 500+ кодов предметов на листе 1. Функция выполняет поиск в диапазоне 200 000+ элементов на листе 2, чтобы найти все совпадения, включая частичные совпадения. Это означает, что мы добавляем символы подстановки до и после критерия поиска, чтобы найти все совпадения.

В настоящее время требуется более 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  

200 000 + КОДЫ ПОЛНЫХ ПУНКТОВ

Sheet2:  

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

Результат должен быть:

Лист1:

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

Answer 1

Чтобы сохранить все текущие функциональные возможности и удобство использования в отношении размера вашего набора данных, это должно работать для вас и быть быстрее, чем исходный код. Когда я рассчитал время, я использовал 400 000 полных кодов элементов и применил формулу concatif на листе 1 для 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

Answer 2

Чтобы использовать следующий код, вам нужно добавить ссылку на 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