0

I have a macro, that dynamically generates n number of pivot tables. I am trying to code to ensure that pivot tables that meet a specific set of conditions are highlighted.

My conditions are as follows

  1. all Values that fall in the Row online and are equal to 2 days (in one color "Orange")
  2. all Values that fall in the Row online and are greater than 2 days (in one color "Red")
  3. all cells that are under any header greater than 5 days (in another color "Yellow")
  4. any time the headers are 5 days or more, then the headers themselves are highlighted in "Yellow"

The code for the same are as follows.

Sub conditionalFormatingPivotTable(ByVal Worksheet As String)

Dim pt As PivotTable, pf As PivotField, pi As PivotItem, d
Dim rngTwoDays As Range, rngFiveDays As Range, rwOnline As Range, c As Range

Set pt = Worksheets("Summary").PivotTables(Worksheet & "PivotTable") 'Setting the pivot table
pt.TableRange1.Interior.ColorIndex = xlNone 'Removing any kind of highlighting that exists


'Start coloring

' x days labels >=5days
Set pf = pt.PivotFields(Worksheet)
For Each pi In pf.PivotItems
    d = Val(pi.Name) 'days number only
    If d >= 5 Then pi.LabelRange.Resize(2).Interior.Color = vbYellow
    If d = 5 Then Set rngFiveDays = pi.DataRange 'for next block
    If d = 2 Then Set rngTwoDays = pi.DataRange  'for next block
Next pi

'the rest
Set pf = pt.PivotFields("Order Category")
For Each pi In pf.PivotItems
    If pi.Name = "Online" Then
        For Each c In pi.DataRange.Cells
            If c.Value > 0 And c.column >= rngTwoDays.column Then
                If Not Application.Intersect(c, rngTwoDays) Is Nothing Then
                    c.Interior.Color = XlRgbColor.rgbOrange
                Else
                    c.Interior.Color = vbRed
                End If
            End If
        Next c
    Else ' will highlight all other Order categories ("Stock & Store")
        For Each c In pi.DataRange.Cells
            If c.Value > 0 And c.column >= rngFiveDays.column Then
                c.Interior.Color = vbYellow
            End If
        Next c
    End If
Next pi

End Sub

Issue is that when I run the code, some of my PIVOT TABLEs (PT's) are highlighted (where conditions are met) whereas others don't get highlighted even though they meet the condition.

in the below example the pivot in btw got highlighted correctly, whereas the top and bottom PT's missed out on the stock data highlighting

Please help in figuring out where the error is.

enter image description here

Improve this question
0

1 Answer 1

Reset to default
2

Please, try the next code. It basically, use a different algorithm to set rngFiveDays range and created condition to skip checking of nothing object column:


Function conditionalFormatingPivotTable(ByVal Worksheet As String)
    Dim pt As PivotTable, pf As PivotField, pi As PivotItem, d
    Dim rngTwoDays As Range, rngFiveDays As Range, rwOnline As Range, c As Range
    
    Set pt = Worksheets("Summary").PivotTables(Worksheet & "PivotTable")
    pt.TableRange1.Interior.ColorIndex = xlNone 'uncolor
    
    ' x days labels >=5days
    Set pf = pt.PivotFields(Worksheet)
    Set rngFiveDays = Nothing
    For Each pi In pf.PivotItems
        d = Val(pi.Name) 'days number only
        If d >= 5 Then
            pi.LabelRange.Resize(2).Interior.Color = vbYellow
            If rngFiveDays Is Nothing Then Set rngFiveDays = pi.DataRange
        End If
        If d = 2 Then Set rngTwoDays = pi.DataRange  'for next block
    Next pi
    
    'the rest
    Set pf = pt.PivotFields("Order Category")
    For Each pi In pf.PivotItems
        If pi.Name = "Online" Then
            For Each c In pi.DataRange.Cells
                If Not rngTwoDays Is Nothing Then '!!!!
                    If c.Value > 0 And c.column >= rngTwoDays.column Then
                        If Not Application.Intersect(c, rngTwoDays) Is Nothing Then
                            c.Interior.Color = XlRgbColor.rgbOrange
                        Else
                            c.Interior.Color = vbRed
                        End If
                    End If
                End If
            Next c
        Else
            For Each c In pi.DataRange.Cells
                If Not rngFiveDays Is Nothing Then '!!!
                    If c.Value > 0 And c.column >= rngFiveDays.column Then
                        c.Interior.Color = vbYellow
                    End If
                End If
            Next c
        End If
    Next pi
End Function

I could see your SortPT function which uses a big manually created array. Like a bonus, please try using the next function, able to automatically create it, according to the interval you set:

Existing array:

rngSort = Array("1 day", "2 days", "3 days", "4 days", "5 days", "6 days", "7 days", "8 days", _
    "9 days", "10 days", "11 days", "12 days", "13 days", "14 days", "15 days", "16 days", "17 days", _
    "18 days", "19 days", "20 days", "21 days", "22 days", "23 days", "24 days", "25 days", "26 days", _
    "27 days", "28 days", "29 days", "30 days", "31 days", "32 days", "33 days", "34 days", "35 days", _
    "36 days", "37 days", "38 days", "39 days", "40 days", "41 days", "42 days", "43 days", "44 days", "45 days")

The function to automatically create it:

Function arrDays(interv As String) As Variant
     Dim arr, frstEl As String
     arr = Split(Replace(interv, " ", ""), "-"): interv = arr(0) + 1 & ":" & arr(1)
     frstEl = IIf(arr(0) = "1", "1 day,", arr(0) & " days,")
     arrDays = Split(frstEl & Join(Evaluate("TRANSPOSE(ROW(" & interv & "))"), " days,") & " days", ",")
End Function

It can be tested in the next way:

Sub testArrDays()
   Dim rngSort, interval As String
   interval = "2-45"
   'interval = "2 - 25" 'just for testing that it works so, too
   rngSort = arrDays(interval)
   Debug.Print Join(rngSort, "|")
End Sub

Not knowing very well all the issued pivot tables peculiarities, I would suggest you to analyze if it is not possible to have cases without "2 days", but to be necessary similar formatting in case of "3 days" existance. Just a thought...

Improve this answer
Sign up to request clarification or add additional context in comments.

18 Comments

@Allwyn P I will be able to suggest a correction if I would understand what you want accomplishing... Do you want copying from the first row following an empty cell in B:B, up to the last cell in column A:A? Or what? Only looking to your code, I am not able to understand what you try doing... How the Source and Destination to be the same?
@Allwyn I only suppose that you need to autofill only on column B:B, but up to the last row in A:A. If so, please try: ws.cells(emptycell + 1, 2).AutoFill Destination:=ws.Range(ws.cells(emptycell + 1, 2), ws.cells(ws.Range("A" & rows.count).End(xlUp).row, 2)), Type:=xlFillDefault. If not, please better clarify what you try accomplishing (in words...).
@Allwyn Besides all that, I would like to tell you that such issues should mean a new question. If I will not be available, somebody else will clarify the issue... But, please focus on better explaining of what you try doing. It is difficult to deduce something from a non working code...
@Allwyn Besides If so, didn't my above suggestion solve your problem?
@Allwyn Besides I may have an idea only if you show me on which code line this error is raised. The code is complex and even if I have some imagination, I cannot say anything in these circumstances. In such a situation, I can only guess that the problem I warned you about maybe hits now. The range for two days definition does not exist and the code tries checking it. But I would like to state that I am not a mind reader...
|

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.