I built a VBA Sub that matches an input string with the equivalent string within a large array and returns a specific string which is bounded to the matched string.

However, while the code is working well with some 100 entries, around 12sec. Around 1000 entries take 1min and 1500 entries might take 3min.

So, I was wondering if there anything I could improve to make the code run faster with a large amount of entries.

The VBA Function:

Sub searchISIN()
       
Dim StartTime As Double
StartTime = Timer
       
lRow = getlastrow(ws_universe, 1)
Dim rngISIN As Range: Set rngISIN = ws_universe.Range("A2:A" & lRow)
Dim z As Long: z = 1
Dim i As Long: i = 1
Dim j As Long

For Each cell In rngISIN
    z = z   1
    For j = LBound(MatchingArr) To UBound(MatchingArr)
        If InStr(1, CStr(MatchingArr(j)), CStr(cell.Value), vbTextCompare) Then
            ws_universe.Cells(z, 2).Value = Left(MatchingArr(j), 18)
            i = i   1
            GoTo NextIteration
        End If
    Next j
    
ws_universe.Cells(z, 2).Value = "k.A."
i = i   1

NextIteration:
    Next cell

MsgBox "Search ISINs: " & Format((Timer - StartTime) / 86400, "hh:mm:ss")

End Sub

The array that gets parsed has around 150k entries and each entry is a string which looks like the following:

"IID00XXXXXXXXXXXX|Magna International Inc.|US55922PF576;US559222AQ72;CA559222AT14;US559222AV67;US55922PRV75;US55922PF329;CA5592224011;XS1689185426;US55922PUW12;US559222AR55"

The code takes an input string, for example CA559222AT14, uses the built-in InStr function and returns the first 18 characters of the current array entry. In this example the return value would be "IID00XXXXXXXXXXXX"

I'm open for any idea to improve the code runtime. There are no constrains, rearranging the array layout, rearranging the complete code or whatsoever.

CodePudding user response：

Looping Through Arrays Instead of Ranges

• Not tested. It will fail if lRow is less than 3.

Option Explicit


Sub searchISIN()
       
    Dim StartTime As Double: StartTime = Timer
           
    lRow = getlastrow(ws_universe, 1)
    Dim rngISIN As Range: Set rngISIN = ws_universe.Range("A2:A" & lRow)
    
    Dim aData As Variant: aData = rngISIN.Value
    Dim bData As Variant: bData = rngISIN.EntireRow.Columns("B").Value
    
    Dim aOffset As Long: aOffset = 1 - LBound(MatchingArr)
    
    Dim aIndex As Variant
    Dim a As Long
    Dim i As Long: i = 1
   
    For a = 1 To UBound(aData, 1)
        aIndex = Application.Match("*" & CStr(aData(a, 1)) & "*", MatchingArr, 0)
        If IsNumeric(aIndex) Then
            bData(a, 1).Value = Left(MatchingArr(aIndex - aOffset), 18)
            i = i   1
        Else
            bData(a, 1) = "k.A."
            i = i   1
        End If
    Next a
    
    rngISIN.EntireRow.Columns("B").Value = bData
    
    MsgBox "Search ISINs: " & Format((Timer - StartTime) / 86400, "hh:mm:ss")

End Sub


Sub searchISINFirst()
       
    Dim StartTime As Double: StartTime = Timer
           
    lRow = getlastrow(ws_universe, 1)
    Dim rngISIN As Range: Set rngISIN = ws_universe.Range("A2:A" & lRow)
    
    Dim aData As Variant: aData = rngISIN.Value
    Dim bData As Variant: bData = rngISIN.EntireRow.Columns("B").Value
    
    Dim a As Long
    
    Dim i As Long: i = 1
    Dim j As Long
    Dim jFound As Boolean
    
    For a = 1 To UBound(aData, 1)
        For j = LBound(MatchingArr) To UBound(MatchingArr)
            If InStr(1, CStr(MatchingArr(j)), CStr(aData(a, 1)), vbTextCompare) Then
                bData(a, 1).Value = Left(MatchingArr(j), 18)
                i = i   1
                jFound = True
                Exit For
            End If
        Next j
        If jFound Then
            jFound = False
        Else
            bData(a, 1) = "k.A."
            i = i   1
        End If
    Next a
    
    rngISIN.EntireRow.Columns("B").Value = bData
    
    MsgBox "Search ISINs: " & Format((Timer - StartTime) / 86400, "hh:mm:ss")

End Sub

CodePudding user response：

I think what you're doing is a good use case for a