Excel VBA to find text and apply font color

Question

MY EXCEL FILE

• Two worksheets: Report and Leaving

• One Named Range: Leavers (list of full names in the Leaving worksheet, column A, some names are red and others are orange).

MY GOAL

I want my macro to find in the Report worksheet (specifically in columns G to M) all the names that are part of the Leavers named range and apply the matching font color to each cell that was found.

MY CODE (SO FAR...)

This code could help by searching them one by one but it doesn't change much from doing it manually with Ctrl + F one by one. I could not find another way around it. Feel free to offer better alternatives, codes and solutions.

Dim Sh As Worksheet
Dim Found As Range
Dim Nme As String
Dim Adr1 As String
 
Nme = Application.InputBox("Enter Name to search", "Test")
 
Set Sh = Sheets("Sheet1")
 
With Sh.Range("A2:A")
 
   Set Found = .Find(What:=Nme, After:=.Range("A2"), _
       LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlNext, _
       MatchCase:=False, SearchFormat:=False)
    If Not Found Is Nothing Then
        Adr1 = Found.Address
    Else
       MsgBox "Name could not be found"
       Exit Sub
    End If
    Do
       Found.Interior.ColorIndex = 4
       Set Found = .FindNext(Found)
    Loop Until Found Is Nothing Or Found.Address = Adr1
End With
End Sub

Answer 1

Try this:

I tried to stick with some of your existing code but I had to make some changes.

1. You need to loop through your first range (I've used "G2:M1000" here on Sheet1 which I guess is your report page?)

2. You can't use a range like "A2:A" in your find routine, so again I've arbitrarily used a 1000 limit: "A2:A1000"

3. You were using interior cell colour, not font colour, I've changed this but if you did mean interior colour then just swap it back

4. I'm not using "Exit Sub" since this will stop everything running the first time it encounters a blank cell / no matching name.

Sub eh()

Dim rng As Range: Set rng = Sheet1.Range("G2:M1000")
Dim v As Range
Dim c As Variant

Dim Found As Range
Dim Nme As String
Dim Adr1 As String

For Each v In rng
    Nme = v.Value2
    If Nme <> "" Then
        Set Found = Sheet2.Range("A2:A1000").Find(What:=Nme, After:=Sheet2.Range("A2"), LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlNext, MatchCase:=False, SearchFormat:=False)
        If Not Found Is Nothing Then
            v.Font.Color = Found.Font.Color
        End If
    End If
Next v

End Sub