Excel VBA to find text and apply font color-CodePudding

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

CodePudding user response：

Try this:

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

You need to loop through your first range (I've used "G2:M1000" here on Sheet1 which I guess is your report page?)
You can't use a range like "A2:A" in your find routine, so again I've arbitrarily used a 1000 limit: "A2:A1000"
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
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

CodePudding user response：

I tried a different approach, I have a subprocedure to loop through the range of the leavers, and when I find a value i give it to another procedure to look for that value in the report range. I am copying all the format of the cells, you can change it to just copy the font color. Also you should check for the ends of each range, to optimize and also this code would loop several times for the same name if the same name repeats in the leavers range, that could be improved.

Sub select_name() 'Select every cell in the leavers range

Dim leaving_range As Range
Dim row_leaving As Range


Set leaving_range = Sheets("Leaving").Range("A2:A10") 'The leavers list, check for the end of the range

For Each row_leaving In leaving_range.Rows

    If row_leaving.Cells(1, 1).Text <> "" Then
        row_leaving.Cells(1, 1).Copy 'I am gonna copy all the format, you change it to copy just the font color
        
        Call look_for_name(row_leaving.Cells(1, 1).Text)

    End If

Next


End Sub


Sub look_for_name(name_to_find As String) 'look for a name in the report range and change the format

Dim report_range As Range
Dim row_report As Range

Set report_range = Sheets("Report").Range("G1:M5") 'the report range where the names are to be found

For Each row_report In report_range.Rows

    For Each cell In row_report.Cells
        
        If cell.Value = name_to_find Then
            cell.PasteSpecial Paste:=xlPasteFormats
        End If

    Next

Next

End Sub