Question

我一直在寻找一种解决方案，允许Excel用户输入一个公式，类似于vlookup，它会将所有唯一匹配值返回给单个单元格。

我编写了以下似乎有效的代码，但我试图在2000+单元格中运行该函数，并且它在我的Thinkstation-S30上运行速度非常慢，我担心它会让任何试图打开文件的人崩溃机器较慢。有没有人对如何提高功能效率有任何想法？我为邋code的代码道歉，我是一名交易会计师......

Public Function MvalLookup(Lookup_vector As Range, Result_vector As Range,_
Criteria As Variant, Seperator As String)
'
' Returns a list of all unique values matching the criteria
'

Dim arr As New Collection, a
Dim i As Integer
Dim j As Integer
Dim z As Integer
Dim result As String
Dim lookuprange As Integer

z = Lookup_vector.Rows.Count
j = 0
On Error Resume Next
For lookuprange = 1 To z
'determine how many values match- determine the required array size
If CStr(Lookup_vector(lookuprange, 1)) = CStr(Criteria) Then
    arr.Add CStr(Result_vector(lookuprange, 1)), CStr(Result_vector(lookuprange, 1))
    j = j + 1
End If
Next lookuprange

' Write results

result = arr(1)
If arr.Count <= 1 Then GoTo Output
For i = 2 To arr.Count
     result = result & Seperator & arr(i)
Next

Output:
'Output results
MvalLookup = result

End Function

Answer 1

感谢拉尔夫的链接，该文章中的建议确实有所帮助。只需将范围存储为数组，就可以将处理时间缩短近10秒！

以下是修订后的代码：

Public Function MvalLookup(Lookup_vector As Range, Result_vector As Range,_
Criteria As Variant, Seperator As String)
'
' MValLookup Macro
' Returns a list of all unique values matching the criteria
'

Dim arr As New Collection, a
Dim i As Integer
Dim j As Integer
Dim z As Integer
Dim result As String
Dim lookuprange As Integer
Dim LUVect As Variant
Dim RESVect As Variant

z = Lookup_vector.Rows.Count
j = 0
LUVect = Lookup_vector.Value2
RESVect = Result_vector.Value2
On Error Resume Next
For lookuprange = 1 To z
'determine how many values match- determine the required array size
If CStr(LUVect(lookuprange, 1)) = CStr(Criteria) Then
    arr.Add CStr(RESVect(lookuprange, 1)), CStr(RESVect(lookuprange, 1))
    j = j + 1
End If
Next lookuprange

' Write results

result = arr(1)
If arr.Count <= 1 Then GoTo Output
For i = 2 To arr.Count
     result = result & Seperator & arr(i)
Next

Output:
'Output results
MvalLookup = result

End Function

VBA函数返回所有唯一匹配值

1 个答案: