Excel需要很長時間來計算UDFVBA

example2 example1 我要匹配的檔案名在 A 行，我正在查看 Row I 以查看是否有匹配項我找到了此代碼我不記得在哪里但我正在嘗試匹配零件編號行到其影像檔案名的一行。這段代碼有效，但是，當我運行它時存在一個問題，即使只計算 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) & 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

uj5u.com熱心網友回復：

編輯（查看資料后）：以下應該明顯更快（以及明顯更簡單）

'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為僅包含資料的行（而不是整個列）。

另外：不知道所有可能的情況，就不可能肯定地說。但是，很有可能，這可以通過 Native excel 函式來完成，并且（如果是這樣）將提供最佳性能。

uj5u.com熱心網友回復：

如上所述，通過將范圍分配給陣列來最小化與作業表的互動將使您的宏在結構上更快。未經測驗，但代碼中的這些細微更改應該可以幫助您走上正軌：

    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) & 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

uj5u.com熱心網友回復：

我試圖修改您現有的代碼，但我發現使用我認為更好的結構來重寫它更容易。并且在運行超過 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: " & Timer * 1000 - StartTime & " 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為接受集合，并且不需要將第二個陣列轉換為集合。

我將把它作為一個想法供你試驗。

標籤：擅长 vba 用户定义函数

上一篇：努力讓VBAShell執行CMD

下一篇：列印到PDF的VBA代碼（僅列印第1到3頁）