如何优化下面的VB代码?运行需要花费大量时间，并且每次都挂起 Excel

Question

我正在 Excel 工作表中创建需求可追溯性 M 矩阵，下面的 VB 代码需要更多时间来执行，并且每次我在单元格中输入内容时，excel 工作表都会挂起 5 分钟。

---

VBA代码：

Function MultipleLookupNoRept(Lookupvalue As String, LookupRange As Range, ColumnNumber As Integer)
Dim xDic As New Dictionary
Dim xRows As Long
Dim xStr As String
Dim i As Long
On Error Resume Next
xRows = LookupRange.Rows.Count
For i = 1 To xRows
If LookupRange.Columns(1).Cells(i).Value = Lookupvalue Then
xDic.Add LookupRange.Columns(ColumnNumber).Cells(i).Value, ""
End If
Next
xStr = ""
MultipleLookupNoRept = xStr
If xDic.Count > 0 Then
For i = 0 To xDic.Count - 1
xStr = xStr & xDic.Keys(i) & ","
Next
MultipleLookupNoRept = Left(xStr, Len(xStr) - 1)
End If 
End Function

Answer 1

↓连接字典中的所有键 ↓

Join(Dictionary.Key(), ",")

Function MultipleLookupNoRept(Lookupvalue As String, LookupRange As Range, ColumnNumber As Integer) As String
Dim xDic As New Dictionary
Dim xRows As Long
Dim xStr As String
Dim i As Long
On Error Resume Next
xRows = LookupRange.Rows.count
For i = 1 To xRows
If LookupRange.Columns(1).Cells(i).Value = Lookupvalue Then
xDic.Add LookupRange.Columns(ColumnNumber).Cells(i).Value, ""
End If
Next
If xDic.count > 0 Then
MultipleLookupNoRept = Join(xDic.Keys(), ",")
End If
End Function

---

这是代码的超修改版本。 前面的代码应在 2-5 秒内处理 10K 行。

Function MultipleLookupNoRept(Lookupvalue As String, LookupRange As Range, ColumnNumber As Integer) As String
Dim addresses As Variant, values As Variant
Dim r As Long
With LookupRange.Parent
With Intersect(LookupRange.Columns(1), .UsedRange)
values = .Value
addresses = .Columns(ColumnNumber).Value
End With
End With
With CreateObject("System.Collections.ArrayList")
For r = 1 To UBound(values)
If values(r, 1) = Lookupvalue And r <= UBound(addresses) And addresses(r, 1) <> "" Then
.Add addresses(r, 1)
End If
Next
MultipleLookupNoRept = Join(.ToArray(), ",")
End With
End Function