Excel 计算 UDF 需要很长时间 VBA
Excel taking really long to calculate a UDF VBA
example2 example1 The file name I'm trying to match is on Row A and I'm looking through Row I to see if there is a match 我不记得在哪里找到了这段代码，但我试图将一行零件号与其图像文件名的一行相匹配。这段代码有效，但是，当我 运行 计算即使只有 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
如前所述，通过将范围分配给数组来最小化与 sheet 的交互将从结构上使您的宏更快。
未经测试，但代码中的这些小改动应该可以帮助您走上正轨：
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
我试图修改您现有的代码，但我发现使用我认为更好的结构重写它更容易。而在 运行 超过 26 列 & 432 行的代码后，只用了 0.2 秒就找到了最接近的匹配字符串。
我将每个值都移到了一个数组中。
我将 lookup_value 和“单元格值”转换为字节数组。
我比较了字节数组以计算匹配的“字符”。
然后我 return 具有最多匹配“字符”的字符串。
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 以接受一个集合，并且不需要将第二个数组转换为集合。
我会把它作为一个想法留给你去试验。
编辑（post 查看数据）：以下内容应该明显更快（也更简单）
'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 函数来完成，并且（如果是的话）这将提供最佳性能。
example2 example1 The file name I'm trying to match is on Row A and I'm looking through Row I to see if there is a match 我不记得在哪里找到了这段代码，但我试图将一行零件号与其图像文件名的一行相匹配。这段代码有效，但是，当我 运行 计算即使只有 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
如前所述，通过将范围分配给数组来最小化与 sheet 的交互将从结构上使您的宏更快。 未经测试，但代码中的这些小改动应该可以帮助您走上正轨：
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
我试图修改您现有的代码，但我发现使用我认为更好的结构重写它更容易。而在 运行 超过 26 列 & 432 行的代码后，只用了 0.2 秒就找到了最接近的匹配字符串。
我将每个值都移到了一个数组中。
我将 lookup_value 和“单元格值”转换为字节数组。
我比较了字节数组以计算匹配的“字符”。
然后我 return 具有最多匹配“字符”的字符串。
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 以接受一个集合，并且不需要将第二个数组转换为集合。
我会把它作为一个想法留给你去试验。
编辑（post 查看数据）：以下内容应该明显更快（也更简单）
'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 函数来完成，并且（如果是的话）这将提供最佳性能。