Find all Partial matches in Sheet 1 Column D that match names in Sheet 2 Column A

[westc4]

Hello,

I am trying to tweak the following VBA code. What I need to happen is for excel to look at the list of names in Column "A" Sheet "Name" and highlight all cells in Column "D" on Sheet "Match" that match the "A" list, a partial name match should be highlighted.

Both the sheets ("Name" and "Match") can have a different number of rows that can vary, so I also need to make sure it searches all names and reviews for all possible matches.

It currently is not finding anything, though there are a number or direct matches and more than 1,000 partial matches.

Sub CheckNames()
Dim Cell As Range, cRange As Range, sRange As Range, Rng As Range, FindString As String

LastRow1 = Sheets("Match").Cells(Rows.Count, "D").End(xlUp).Row
LastRow2 = Sheets("Name").Cells(Rows.Count, "A").End(xlUp).Row

Set cRange = Sheets("Match").Range("D3:D" & LastRow1)
Set sRange = Sheets("Name").Range("A1:A" & LastRow2)

    For Each Cell In cRange
        FindString = Cell.Value
    With sRange
         Set Rng = .Find(What:=FindString, _
                    After:=.Cells(1), _
                    LookIn:=xlValues, _
                    LookAt:=xlPart, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False)
            If Not Rng Is Nothing Then
                Rng.Interior.ColorIndex = 6
                    Cell.Interior.ColorIndex = 6
            End If
    End With
    Next
End Sub

 

[Marcelo Branco]

I think to speed it up we can use a string to build the range to be colored - checking if the string has less than 255 characters

Something like this

Sub aTest()
    Dim strRange As String, LastRow1 As Long, LastRow2 As Long
    Dim rName As Range, rSearch As Range, rn As Range, rs As Range
    
    LastRow1 = Sheets("Match").Cells(Rows.Count, "D").End(xlUp).Row
    LastRow2 = Sheets("Name").Cells(Rows.Count, "A").End(xlUp).Row
    
    Set rSearch = Sheets("Match").Range("D2:D" & LastRow1)
    Set rName = Sheets("Name").Range("A2:A" & LastRow2)

    Sheets("Name").Activate
    For Each rn In rName
        For Each rs In rSearch
            If UCase(rs.Value) Like "*" & UCase(rn.Value) & "*" Then
                If Len(strRange) + Len(rn.Address(False, False)) < 255 Then
                    strRange = strRange & "," & rn.Address(False, False)
                Else
                    rn.Interior.Color = vbYellow
                    Range(Mid(strRange, 2)).Interior.Color = vbYellow
                    strRange = ""
                End If
            End If
        Next rs
    Next rn
    If Len(strRange) Then Range(Mid(strRange, 2)).Interior.Color = vbYellow
                    
End Sub

M.

 

[CalcSux78]

Joe, you are definitely right on that. My preferred method is using arrays to store data and send changes back as a whole. Processing 100,000+ rows of data in fractions of a second. Without a full data set (I realize it's not feasible or secure for this scenario), it's hard to adjust for calculation performance.