Excel VBA InStr very slow and hanging - vba

Question

I am using the below VBA code to compare 60K records (only a particular string) from 'Sheet1' with 7K records from 'Sheet2'. It's taking a very long time to complete and is unresponsive at times. Is there anyway to improve the performance of this subroutine?
Sub txtext()
Dim fnl As String, stl As String, env As String, typ As String
Dim ctm As String
Dim stdate As Date, enddate As Date
lr = Sheets("cid_match").Range("A" & Rows.Count).End(xlUp).Row
cr = Sheets("scme").Range("C" & Rows.Count).End(xlUp).Row
stdate = Now
m = 2
For Each e In Sheets("cid_match").Range("BI2:BI" & lr).Cells
stl = Worksheets("cid_match").Range("BI" & m).Cells.Value
typ = Worksheets("cid_match").Range("BK" & m).Cells.Value
s = 2
For Each r In Sheets("scme").Range("C2:C" & cr).Cells
ctm = Worksheets("scme").Range("B" & s).Cells.Value
fnl = r.Value
If InStr(fnl, stl) > 0 And ctm = typ Then
Worksheets("cid_match").Range("BJ" & m).Value = fnl
GoTo sss
End If
s = s + 1
Next r
sss:
m = m + 1
Next e
enddate = Now
MsgBox "Succesfully Completed!!! Started at " & stdate & " Ended at " & enddate
End Sub

Answer 1

In order to optimize searching for a record you want to firstly sort your data using either quicksort or bubblesort. Then you will be able to search through using binary search. This will significantly reduce your wait times. Lucky you, these functions have already been written in VBA by other developers.
Bubblesort
Sub BubbleSort(list())
' Sorts an array using bubble sort algorithm
Dim First As Integer, Last As Long
Dim i As Long, j As Long
Dim Temp As Long
First = LBound(list)
Last = UBound(list)
For i = First To Last - 1
For j = i + 1 To Last
If list(i) > list(j) Then
Temp = list(j)
list(j) = list(i)
list(i) = Temp
End If
Next j
Next i
End Sub
Binary Search
Function arrayFind(theArray() As Integer, target As Integer) As Boolean
Dim low As Integer
low = 0
Dim high As Integer
high = UBound(theArray)
Dim i As Integer
Dim result As Boolean
Do While low <= high
i = (low + high) / 2
If target = theArray(i) Then
arrayFind = True
Exit Do
ElseIf target < theArray(i) Then
high = (i - 1)
Else
low = (i + 1)
End If
Loop
If Not arrayFind Then
arrayFind = False
End If
End Function

Answer 2

Try the below: -
Sub Sample()
Dim AryLookup() As String
Dim DteStart As Date
Dim LngCounter As Long
Dim LngRow As Long
Dim WkSht As Worksheet
DteStart = Now
'Look at the lookup worksheet
Set WkSht = ThisWorkbook.Worksheets("scme")
'Make an array the same size as the dataset
ReDim AryLookup(WkSht.Range("C" & Rows.Count).End(xlUp).Row)
'Copy the dataset in
For LngRow = 2 To UBound(AryLookup, 1)
AryLookup(LngRow - 2) = WkSht.Range("C" & LngRow)
DoEvents
Next
Set WkSht = Nothing
'Look at the source worksheet
Set WkSht = ThisWorkbook.Worksheets("cid_match")
'Work from the bottom up so not to be falsly stopped by an empty row
'Step -1 means go backwards by one with each itteration of the loop
For LngRow = WkSht.Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
'Look through the loop for a match
For LngCounter = 0 To UBound(AryLookup, 1)
'If it matches then add it to the column and exit the loop
If InStr(1, WkSht.Range("BI" & LngRow), AryLookup(LngCounter)) > 0 Then
WkSht.Range("BJ" & LngRow).Value = AryLookup(LngCounter)
Exit For
End If
DoEvents
Next
DoEvents
Next
Set WkSht = Nothing
MsgBox "Succesfully Completed!!! " & vbNewLine & "Started at " & DteStart & vbNewLine & "Ended at " & Now
End Sub
Looking over your code was quite confusing to follow what was happening, in some cases I couldn't understand or see the benefit in what was happening in the code, so the above may not be correct. You should always write your code with the assumption that another developer will need to pick it up and support it one day, it'll help you in the future if you have to return to it years later and want to remember what is happening.