vba to fill cell color

[PinakiB]

Hi MrExcel,

I am in confusion to fill the color of cell. Actually I have some serial numbers in Column A where few serial numbers are in yellow highlights and in Column B I have those same serial numbers but few cells values are not matched and in disorder format in comparison of Column A. What I am looking for the color cells of Column A with values to be fulfilled in Column B meaning if A2 & A4 & A7 has the yellow highlights in Column A then those data should match in Column B and if those data exists in B5, B10, B15 of Column B, fill the yellow highlights respectively. Please help me as I am stucked.

Thanks & Regards,

Pinaki

 

[Domenic]

Try the following code, which needs to be placed in a regular module (VBE > Insert > Module)...

[color=darkblue]Option[/color] [color=darkblue]Explicit[/color]

[color=darkblue]Sub[/color] HighlightCorrespondingCells()

    [color=darkblue]Dim[/color] rHighlightedRange [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] rRangeToHighlight [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] rFound [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] rCell [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] sFirstAddress [color=darkblue]As[/color] [color=darkblue]String[/color]

    [color=darkblue]If[/color] TypeName(ActiveSheet) <> "Worksheet" [color=darkblue]Then[/color] [color=darkblue]Exit[/color] [color=darkblue]Sub[/color]
    
    [color=darkblue]Const[/color] MYCOLOR [color=darkblue]As[/color] [color=darkblue]Long[/color] = vbYellow
    
    [color=darkblue]Set[/color] rHighlightedRange = Columns("A")
    [color=darkblue]Set[/color] rRangeToHighlight = Columns("B")
    
    [color=darkblue]With[/color] Application.FindFormat
        .Clear
        .Interior.Color = MYCOLOR
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
    [color=darkblue]With[/color] rHighlightedRange
        [color=darkblue]Set[/color] rFound = .Find(What:="", after:=.Cells(1), LookIn:=xlFormulas, LookAt:=xlPart, _
                        SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=True)
        [color=darkblue]If[/color] [color=darkblue]Not[/color] rFound [color=darkblue]Is[/color] [color=darkblue]Nothing[/color] [color=darkblue]Then[/color]
            sFirstAddress = rFound.Address
            [color=darkblue]Do[/color]
                DoHighlight rFound.Value, rRangeToHighlight, MYCOLOR
                [color=darkblue]Set[/color] rFound = .Find(What:="", after:=rFound, LookIn:=xlFormulas, LookAt:=xlPart, _
                        SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=True)
            [color=darkblue]Loop[/color] [color=darkblue]While[/color] rFound.Address <> sFirstAddress
            MsgBox "Completed . . .", vbInformation
        [color=darkblue]Else[/color]
            MsgBox "No highlighted cells found . . .", vbExclamation
        [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
    Application.FindFormat.Clear
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

[color=darkblue]Private[/color] [color=darkblue]Sub[/color] DoHighlight([color=darkblue]ByVal[/color] vSearchFor [color=darkblue]As[/color] [color=darkblue]Variant[/color], [color=darkblue]ByVal[/color] rSearchRange [color=darkblue]As[/color] Range, [color=darkblue]ByVal[/color] lColor [color=darkblue]As[/color] [color=darkblue]Long[/color])

    [color=darkblue]Dim[/color] rFound [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] sFirstAddress [color=darkblue]As[/color] [color=darkblue]String[/color]
    
    [color=darkblue]With[/color] rSearchRange
        [color=darkblue]Set[/color] rFound = .Find(What:=vSearchFor, after:=.Cells(1), LookIn:=xlFormulas, LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        [color=darkblue]If[/color] [color=darkblue]Not[/color] rFound [color=darkblue]Is[/color] [color=darkblue]Nothing[/color] [color=darkblue]Then[/color]
            sFirstAddress = rFound.Address
            [color=darkblue]Do[/color]
                rFound.Interior.Color = lColor
                [color=darkblue]Set[/color] rFound = .FindNext(after:=rFound)
            [color=darkblue]Loop[/color] [color=darkblue]While[/color] rFound.Address <> sFirstAddress
        [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]End[/color] [color=darkblue]With[/color]

[color=darkblue]End[/color] [color=darkblue]Sub[/color]

Hope this helps!

 

[PinakiB]

Hi Domenic,

Excellent!!What I was looking for got the exact code. Thank you so much. Its worked absolutely perfect for me.

Regards,
Pinaki