vbaexcelrtm

How to optimize the below VB Code? It is taking lot of time to run and Excel is hanging every time


I am creating a Requirement Traceablity M matrix in the Excel sheet and below VB code is taking more time to execute and excel sheet is hanging for 5 minutes every time I enter something in a cell.


VBA code:

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

Solution

  • ↓Concatenate all the keys in a Dictionary ↓

    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
    

    Here is the ultra modified version of the code. The previous code should process 10K rows in 2-5 seconds.

    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