Find multiple names in range and change color

[jolivanes]

I want to change the font color for certain found names in a range.

Sub ColorThePeople()

    DR1 = "Person One"
    DR2 = "Person Two"
    DR3 = "Person Three"
    DR4 = "Person Four"
    DR5 = "Person Five"
    DR6 = "Person Six"
    DR7 = "Person Seven"
    DR8 = "Person Eight"
    DR9 = "Person Nine"
    DR10 = "Person Ten"
    DR11 = "Person Eleven"
    DR12 = "Person Twelve"

    i = 1
     
    For Each c In Range("G4", Range("G" & Rows.Count).End(xlUp))
    
        With ActiveSheet
            Set rFound = .Columns(7).Find(What:=DR & i, After:=.Cells(4, 7), LookIn:=xlValues, LookAt:= _
                                          xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                       , SearchFormat:=False)
        End With
        rFound.Font.ColorIndex = 45

    i = i + 1
    Next
End Sub

I hoped that the above code would do it but it colors about 70 percent of the entries in the column. At the moment there are +/- 200 names so obviously the code does not work.
It seems that it does not like the "DR & i" in the "Find(What:=DR & i," part.

Could someone set me straight on this please.

Thank you very much in advance

John

 

[Trebor76]

Hi John,

Try this:

Sub ColourThePeople()
    
    Dim strArrayList As String
    Dim varTempArray As Variant, _
        varArrayItem As Variant
    Dim rngCell As Range, _
        rngFound As Range
    
    'Create a string of items to be looked up, each separated by a comma.
    strArrayList = "Person One," & _
                   "Person Two," & _
                   "Person Three," & _
                   "Person Four," & _
                   "Person Five," & _
                   "Person Six," & _
                   "Person Seven," & _
                   "Person Eight," & _
                   "Person Nine," & _
                   "Person Ten," & _
                   "Person Eleven," & _
                   "Person Twelve"

    varTempArray = Split(strArrayList, ",")
    
    Application.ScreenUpdating = False
    
    For Each varArrayItem In varTempArray
    
        With ActiveSheet
            'Turn off any existing filters
            .AutoFilterMode = False
            'Filter the relevant range by the array item
            .Range("G4:G" & .Cells(Rows.Count, "G").End(xlUp).Row).AutoFilter Field:=1, Criteria1:="=" & varArrayItem
            'If the first cell in the range doesn't equal the array item, then...
            If .Range("G4") <> varArrayItem Then
                '...hide it as its' font colour must not be changed
                .Rows("4").EntireRow.Hidden = True
            End If
            'Colour the font of all the visible cells in the range
            .Range("G4:G" & .Cells(Rows.Count, "G").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Font.ColorIndex = 45
            'Turn off filter
            .AutoFilterMode = False
            'Unhide heading row
            .Rows("4").EntireRow.Hidden = False
        End With
        
    Next varArrayItem
    
    Application.ScreenUpdating = True
    
End Sub

HTH

Robert

 

[jolivanes]

Hi Robert.
Thank you very much for your reply.
What I should have mentioned Robert is that the "people" have numbers in front of the person. For instance "10. Person One" or "103. Person Six" etc etc (without quotation marks). These numbers change from day to day though.
The code you supplied me with Robert did not color the relevant names and I think, I might be totally wrong here, that that is because of the numbers in front.

Thank you and Regards

John

 

[Sektor]

[COLOR="Blue"]Sub[/COLOR] ColorThePeople()

    [COLOR="Blue"]Dim[/COLOR] c [COLOR="Blue"]As[/COLOR] Range, arr [COLOR="Blue"]As[/COLOR] [COLOR="Blue"]Variant[/COLOR], i [COLOR="Blue"]As[/COLOR] [COLOR="Blue"]Integer[/COLOR]

    arr = VBA.Array("Person One", "Person Two", "Person Three", "Person Four", "Person Five", "Person Six", _
                    "Person Seven", "Person Eight", "Person Nine", "Person Ten", "Person Eleven", "Person Twelve")

    [COLOR="Blue"]For[/COLOR] [COLOR="Blue"]Each[/COLOR] c [COLOR="Blue"]In[/COLOR] Range("G4", Range("G" & Rows.Count).End(xlUp))
        [COLOR="Blue"]For[/COLOR] i = 0 [COLOR="Blue"]To[/COLOR] [COLOR="Blue"]UBound[/COLOR](arr)
            [COLOR="Blue"]If[/COLOR] c [COLOR="Blue"]Like[/COLOR] "*" & arr(i) & "*" [COLOR="Blue"]Then[/COLOR]
                c.Font.Interior.ColorIndex = 45
                [COLOR="Blue"]Exit[/COLOR] [COLOR="Blue"]For[/COLOR]
            [COLOR="Blue"]End[/COLOR] [COLOR="Blue"]If[/COLOR]
        [COLOR="Blue"]Next[/COLOR]
    [COLOR="Blue"]Next[/COLOR]

[COLOR="Blue"]End[/COLOR] [COLOR="Blue"]Sub[/COLOR]

 

[jolivanes]

Hi Sektor
When changing the "slipped of the keyboard"

c.Font.Interior.ColorIndex = 45

to

c.Font.ColorIndex = 45

it worked like a charm.

Thank you both very much for your help.

Regards
John

 

[Sektor]

Ah, forgot to delete!
Glad that helped you!

 

[Trebor76]

You're welcome and nice solution Sektor

 

[Jaye7]

Sektor,

Can you please provide the script for a PARTIAL match, i.e eight or seven.

Cell text may have Person Eight has total of 5 etc...