如何优化下面的VB代码？它需要花费大量的时间来运行，而Excel每次都挂起 我在Excel表格中创建了一个需求可跟踪性M矩阵，下面的VB代码需要更多的时间来执行，每次我在单元格中输入内容时，Excel表格都会挂起5分钟。 VBA代码：

↓连接字典中的所有键↓

---

下面是代码的超修改版本。前面的代码应该在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

函数MultipleLookupNoRept（Lookupvalue作为字符串，LookupRange作为范围，ColumnNumber作为整数）作为字符串
Dim地址作为变量，值作为变量
变暗，变长
使用LookupRange.Parent
带Intersect（LookupRange.Columns（1），.UsedRange）
值=.Value
地址=.Columns（ColumnNumber）.Value
以
以
使用CreateObject（“System.Collections.ArrayList”）
对于r=1到UBound（值）
如果值（r，1）=Lookupvalue和r，则无需检查字典中是否已存在该值，只需执行
xDic（Lookupvalue）=“”
。同样，在循环之前将LookupRange转换为2d数组，并在循环中处理数组，而不是范围。RTM是需求跟踪矩阵如果没有人能将“救赎”一词转化为他们的答案，我会非常失望。现在它被挂起的时间超过了5分钟。。它没有得到优化。还是没有working@SHASHANKBalaganchi我附加了另一个版本的函数，该函数可以调整范围以适应数据。处理上一个答案需要很长时间的唯一方法是，如果
LookupRange
有+500K个单元格，那么超级代码@TinMan。非常高兴。超版本是可怕的，工作完美。没想到你的服务这么快！！高兴的编码：）想知道是否会加快一点。
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

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