Lookup pivot and highlight

Hi,

Im loking for some code that will look at the data in ColA in one pivot and if there is a matching entry in ColA in a pivot on another tab, highlight the whole row green, if it is not a  match, highlight it red.

I did the first as an example

Thanks
Seamus
test.zip
Seamus2626Asked:
Who is Participating?

Improve company productivity with a Business Account.Sign Up

x
 
dlmilleConnect With a Mentor Commented:
I would use this code:

Sub matchPivots()
Dim wkb As Workbook
Dim wksA As Worksheet
Dim wksB As Worksheet
Dim rng As Range
Dim r As Range
Dim rFind As Range
Dim rColor As Range

    Set wkb = ThisWorkbook
    Set wksA = wkb.Sheets("ASPA Pivot")
    Set wksB = wkb.Sheets("Sophis Pivot")
    
    Set rng = wksA.Range("A5", wksA.Range("A" & Rows.Count).End(xlUp).Offset(-1, 0))
    
    For Each r In rng
        Set rColor = wksA.Range(r, wksA.Cells(r.Row, "G"))
        Set rFind = wksB.Range("A:A").Find(what:=r.Value, LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext)
        If Not rFind Is Nothing Then
            rColor.Interior.Color = vbGreen
        Else
            rColor.Interior.Color = vbRed
        End If
    Next r
    
End Sub

Open in new window


See attached.

Dave
match-pivots-r1.xls
0
 
Seamus2626Author Commented:
Thanks Dave!

Seamus
0
 
Seamus2626Author Commented:
One question Dave, the colours expand to col G, however the pivots shrink and expand with new data. There is always a grand total for for Columns, so could you amend so the colouring only goes as far as "Grand Total"

Thanks
Seamus
0
 
dlmilleCommented:
Sure.  It searches for "Grand Total" on row 4, if not found, then uses last column on row 4.  Change the row number if you move the pivot table:

Option Explicit

Sub matchPivots()
Dim wkb As Workbook
Dim wksA As Worksheet
Dim wksB As Worksheet
Dim rng As Range
Dim r As Range
Dim rFind As Range
Dim rColor As Range
Dim lastCol As Long

    Set wkb = ThisWorkbook
    Set wksA = wkb.Sheets("ASPA Pivot")
    Set wksB = wkb.Sheets("Sophis Pivot")
    
    Set rng = wksA.Range("A5", wksA.Range("A" & Rows.Count).End(xlUp).Offset(-1, 0))
    
    On Error Resume Next
    lastCol = wksA.Range("4:4").Find(what:="Grand Total", LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByColumns, searchdirection:=xlNext).Column
    If lastCol = 0 Then
        lastCol = wksA.Cells(4, Columns.Count).End(xlToLeft).Column
    End If
    On Error Resume Next
    
    For Each r In rng
        Set rColor = wksA.Range(r, wksA.Cells(r.Row, lastCol))
        Set rFind = wksB.Range("A:A").Find(what:=r.Value, LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext)
        If Not rFind Is Nothing Then
            rColor.Interior.Color = vbGreen
        Else
            rColor.Interior.Color = vbRed
        End If
    Next r
    
End Sub

Open in new window


See attached.

Dave
match-pivots-r2.xls
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.