Блог

пример1 Имя файла, которое я пытаюсь сопоставить, находится в строке A, и я просматриваю строку I, чтобы увидеть, есть ли совпадение пример2 Я нашел этот код, не могу вспомнить где, но я пытаюсь сопоставить строку номеров деталей с строкой имен файлов его изображений. Этот код работает, однако при его запуске возникает проблема: вычисление даже 1 столбца занимает очень много времени, и когда я делаю сотни за раз, мой Excel просто перестает отвечать, и у меня есть тысячи продуктов, которые мне нужно сопоставить. Я действительно новичок в VBA, поэтому я даже не могу понять проблему.

Пожалуйста, помогите, спасибо.

 'Name function and arguments
Function SearchChars(lookup_value As String, tbl_array As Range) As String
'Declare variables and types
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
'Iterste through each cell
For Each cell In tbl_array
  'Save cell value to variable
  str = cell
  'Iterate through characters
  For i = 1 To Len(lookup_value)
    'Same character?
    If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
      'Add 1 to number in array
      a = a   1
      'Remove evaluated character from cell and contine with remaning characters
      cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) amp; Mid(cell, InStr(cell, Mid(lookup_value, i, 1))   1, 9999)
    End If
  'Next character
  Next i
 
a = a - Len(cell)
'Save value if there are more matching characters than before  
If a > b Then
  b = a
  Value = str
End If
 
a = 0
Next cell
'Return value with the most matching characters
SearchChars = Value
End Function
 

РЕДАКТИРОВАТЬ (после просмотра данных): следующее должно быть заметно быстрее (а также заметно проще)

 'Name function and arguments
Function SearchChars(lookup_value As String, tbl_array As Range) As String
    
    'Declare variables and types
    Dim inLenMatched%, vnVal, varLookupValues()
    
    'Puts lookup cell values into a array (to speed things up)
    varLookupValues = tbl_array.Value
    
    'Iterate through each lookup value
    For Each vnVal In varLookupValues
      
        'Ignore empty cells
        If vnVal <> "" Then
            
            'Does part number appear in filename?
            If InStr(lookup_value, vnVal) > 0 Then
                
                'Is this match the most complete match so far?
                If Len(vnVal) > inLenMatched Then
                    inLenMatched = Len(vnVal)
                    SearchChars = vnVal
                End If
             End If
        End If
        
    Next vnVal
    
    'Return match value (or 'No Match' if not matched)
    If SearchChars = "" Then SearchChars = "No Match"

End Function
 

Вышеизложенное — всего лишь один нестандартный подход.
Есть другие (и, возможно, более быстрые) способы приблизиться к этому.

Наиболее очевидным шагом (независимо от метода) для повышения производительности было бы ограничение tbl_array только строками с данными (а не всем столбцом).

Отдельно: не зная всех возможных случаев, невозможно сказать наверняка. Но, по всей вероятности, это можно сделать с помощью собственных функций Excel, и (если это так) это обеспечит наилучшую производительность.

Как уже было сказано, минимизация взаимодействия с листом путем присвоения диапазона массиву структурно ускорит ваши макросы. Не проверено, но эти незначительные изменения в вашем коде должны помочь вам на правильном пути:

     Option Explicit
    'Name function and arguments
    Function SearchChars2(lookup_value As String, tbl_array As Range) As String
    'Declare variables and types
    Dim i As Integer, str As String, Value As String
    Dim a As Integer, b As Integer, cell As Variant
    'Iterste through each cell => replace with array
    'adapt to correct sheet
    Dim arr
    arr = tbl_array
    
    For Each cell In arr 'tbl_array
        'Save cell value to variable
        str = cell
        'Iterate through characters
        For i = 1 To Len(lookup_value)
          'Same character?
          If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
            'Add 1 to number in array
            a = a   1
            'Remove evaluated character from cell and contine with remaning characters
            cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) amp; Mid(cell, InStr(cell, Mid(lookup_value, i, 1))   1, 9999)
          End If
        'Next character
        Next i
     
        a = a - Len(cell)
        'Save value if there are more matching characters than before
        If a > b Then
          b = a
          Value = str
        End If
         
        a = 0
        Next cell
    'Return value with the most matching characters
    SearchChars2 = Value
    End Function
 

Я пытался изменить ваш существующий код, но мне было проще просто переписать его, используя то, что я считаю лучшей структурой. И после запуска кода по 26 столбцам и 432 строкам потребовалось всего 0,2 секунды, чтобы найти ближайшую соответствующую строку.

Я переместил каждое значение в массив. Я преобразовал lookup_value и «значения ячеек» в массив байтов. Я сравнил массивы байтов для подсчета совпадающих «символов». И затем я возвращаю строку, в которой было наибольшее количество совпадающих «символов».

 Sub Example()
    Dim StartTime As Double
    StartTime = Timer * 1000
    Debug.Print SearchChars3("Toddleson", Range("A1:Z432"))
    Debug.Print "Time Elapsed: " amp; Timer * 1000 - StartTime amp; " ms"
    'Time Elapsed: 171.875 ms
End Sub

Function SearchChars3(lookup_value As String, tbl_array As Range) As String
    Dim ClosestMatch As String, HighestMatchCount As Integer
    
    Dim tbl_values() As Variant
    tbl_values = tbl_array.Value
    
    Dim LkUpVal_Bytes() As Byte
    LkUpVal_Bytes = ToBytes(lookup_value)
    
    Dim Val As Variant
    For Each Val In tbl_values
        If Val = "" Then GoTo nextVal
        
        Dim Val_Bytes() As Byte
        Val_Bytes = ToBytes(CStr(Val))
        
        Dim MatchCount As Integer
        MatchCount = CountMatchingElements(LkUpVal_Bytes, Val_Bytes)
        
        If MatchCount > HighestMatchCount Then
            HighestMatchCount = MatchCount
            ClosestMatch = Val
        End If
nextVal:
    Next
    SearchChars3 = ClosestMatch
End Function

Function ToBytes(InputStr As String) As Byte()
    Dim ByteArr() As Byte
    ReDim ByteArr(Len(InputStr) - 1)
    Dim i As Long
    For i = 0 To Len(InputStr) - 1
        ByteArr(i) = AscW(Mid(InputStr, i   1, 1))
    Next
    ToBytes = ByteArr
End Function

Function CountMatchingElements(Arr1 As Variant, Arr2 As Variant) As Integer
    'As elements from Arr1 are found in Arr2, those elements are removed from Arr2, to prevent re-matching with the same elements
    'To enable this feature, Arr2 is turned into a Collection
    Dim Col2 As New Collection
    Dim v As Variant
    For Each v In Arr2
        Col2.Add v
    Next
    
    Dim MatchCount As Integer, i As Long
    For Each v In Arr1
        For i = 1 To Col2.Count
            If Col2.Item(i) = v Then
                MatchCount = MatchCount   1
                Col2.Remove (i)
                Exit For
            End If
        Next
    Next
    CountMatchingElements = MatchCount
End Function
 

Дальнейшая оптимизация может заключаться в том, чтобы иметь вторую версию ToBytes функции, которая напрямую выводит значения в Collection . Затем вы можете изменить CountMatchingElements , чтобы принять коллекцию, и ей не нужно будет преобразовывать второй массив в коллекцию.

Я оставлю это как идею для вас, чтобы поэкспериментировать.