Compare each name in one sheet with each string in another - vba

Question

There are two sheets named "Agents" and other one is "Owners" now the Agents sheets has about 37k rows in col "C" with Names like " CLARKE, DENISE JANE" All in one cell.
The other sheet "Owners" has very less about 1k rows of names in col "A" in format like this "Rafael" , "William" ,"Smith" ,etc all in different rows.
I am trying to compare each name in owners sheet with each string in agents sheet.
In this case. First Rafael will be compared with CLARKE then with DENISE then with JANE if match is found background color of Rafael
Now when I run this code it goes in maybe an infinite loop or something but the excel doesn't responds for a long time like 5 - 8 minutes it freezes. Even "Ctrl + Break" doesn't works I have to terminate it via task manager. I tried finding any flaws in this code but I wasn't able to do so.
Can any one help ?
Option Explicit
Sub Duplica()
Dim str1 As String
Dim str2 As String
Dim i, j, m, d, k, l As Long
Dim FinalRow, FinalRow1 As Long
Dim ws, wr As Worksheet
Dim pos As Integer
Dim Own
Dim Ago
Application.ScreenUpdating = False
Set ws = Sheets("Agents")
Set wr = Sheets("Owners")
FinalRow = ws.Range("C90000").End(xlUp).Row
FinalRow1 = wr.Range("A90000").End(xlUp).Row
For i = 1 To FinalRow
l = 0
pos = 0
With ws
str1 = .Cells(i, "C").Text
str1 = Replace(str1, "&", " ")
str1 = Replace(str1, ",", " ")
Ago = Split(str1, " ")
End With
For d = 1 To FinalRow1
With wr
str2 = .Cells(d, "A").Text
str2 = Replace(str2, "&", " ")
str2 = Replace(str2, ",", " ")
Own = Split(str2, " ")
End With
For m = LBound(Ago) To UBound(Ago)
For j = LBound(Own) To UBound(Own)
If Len(Own(j)) > 0 And Len(Ago(m)) > 0 Then 'if not a empty string
pos = InStr(1, Ago(m), Own(j), vbTextCompare) 'Find the owners name in Agents name
If Own(j) = Ago(m) Then 'If both are same
l = l + 1 'increment l
Else: End If
Else: End If
If l > 0 Or pos >= 1 Then
With wr
.Cells(d, "A").Interior.ColorIndex = 3
End With
l = 0
pos = 0
Else: End If
l = 0
pos = 0
Next j
Next m
Next d
Next i
End Sub

Answer 1

Try this out. It is a bit more straight forward. It is still going to take a few minutes as this is a lot of data to process.
The find option of LookAt:=xlPart gives us the search of any part of the field. Let me know if this works. The only issue is we may have an owner named bob and a agent name of Jimbob. That would be a hit. We can change it to look at each name if that is an issue.
Sub Duplica()
Dim wsAgents As Excel.Worksheet
Dim wsOwners As Excel.Worksheet
Dim lRow As Long
Dim Rng As Range
Dim lastRow As Long
Set wsAgents = ActiveWorkbook.Sheets("Agents")
Set wsOwners = ActiveWorkbook.Sheets("Owners")
'Get the last row that has an owner name
lastRow = wsOwners.Cells(wsOwners.Rows.count, "A").End(xlUp).Row
'Loop through the sheet with the owners
lRow = 1
Do While lRow <= lastRow
'Search for the owners name in the column on the agents sheet.
Set Rng = wsAgents.Range("C:C").Find(What:=UCase(wsOwners.Range("A" & lRow).Value), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'If we found the owner on the agent sheet color the owners name red.
If Not Rng Is Nothing Then
wsOwners.Range("A" & lRow).Interior.ColorIndex = 3
End If
Debug.Print str(lRow)
'Increment to the next row
lRow = lRow + 1
Loop
End Sub