VBA code for changing shapes based on cell values connected to Pivot Table/Slicers

[slk927]

Hi all, I am very new to VBA code and attempting to create a color coded heat map based on the user selecting criteria from slicers/pivot table. I am looking to have my code run automatically when someone opens the file, and the shapes on the map (county names) will automatically change color based on a cell's number value. i.e. if a shape's value is 0.15 the color of that shape will change to yellow based on the user's selection in slicers.

below is my code, and like I mentioned, I am first timer in attempting to write and execute so any help is greatly appreciated. The error keeps popping up on the 4th line of 'For Each shp In Sheets("WBIN Map"). error is object doesn't support this property or method. i am using excel 2013

Sub WBINmap()
' WBINmap Macro
    Dim shp As Shape
    For Each shp In Sheets("WBIN Map")
    If Range("G106:G121") <= 0 Then
        ActiveSheet.Shapes.Range(Array("Barnstable", "Belknap", "Cheshire", "Dukes", "Essex", "Hillsborough", "Merrimack", "Middlesex", "Nantucket", "Norfolk", "Plymouth", "Rockingham", "Strafford", "Suffolk", "Windham", "Worcester").Fill.ForeColor.RGB = RGB(192, 192, 192)).Transparency = 0.1999999881
    End If
    Next
    For Each shp In Sheets("WBIN Map")
    If Range("G66:G81") = 0.001 - 0.01 Then
        ActiveSheet.Shapes.Range(Array("Barnstable", "Belknap", "Cheshire", "Dukes", "Essex", "Hillsborough", "Merrimack", "Middlesex", "Nantucket", "Norfolk", "Plymouth", "Rockingham", "Strafford", "Suffolk", "Windham", "Worcester").Fill.ForeColor.RGB = RGB(255, 255, 178)).Transparency = 0.1999999881
    End If
    Next
    For Each shp In Sheets("WBIN Map")
    If Range("G66:G81") = 0.012 - 0.05 Then
        ActiveSheet.Shapes.Range(Array("Barnstable", "Belknap", "Cheshire", "Dukes", "Essex", "Hillsborough", "Merrimack", "Middlesex", "Nantucket", "Norfolk", "Plymouth", "Rockingham", "Strafford", "Suffolk", "Windham", "Worcester").Fill.ForeColor.RGB = RGB(254, 204, 92)).Transparency = 0.1999999881
    End If
    Next
    For Each shp In Sheets("WBIN Map")
    If Range("G66:G81") = 0.051 - 0.1 Then
        ActiveSheet.Shapes.Range(Array("Barnstable", "Belknap", "Cheshire", "Dukes", "Essex", "Hillsborough", "Merrimack", "Middlesex", "Nantucket", "Norfolk", "Plymouth", "Rockingham", "Strafford", "Suffolk", "Windham", "Worcester").Fill.ForeColor.RGB = RGB(253, 141, 60)).Transparency = 0.1999999881
    End If
    Next
    For Each shp In Sheets("WBIN Map")
    If Range("G66:G81") = 0.101 - 0.18 Then
        ActiveSheet.Shapes.Range(Array("Barnstable", "Belknap", "Cheshire", "Dukes", "Essex", "Hillsborough", "Merrimack", "Middlesex", "Nantucket", "Norfolk", "Plymouth", "Rockingham", "Strafford", "Suffolk", "Windham", "Worcester").Fill.ForeColor.RGB = RGB(240, 59, 32)).Transparency = 0.1999999881
    End If
    Next
    For Each shp In Sheets("WBIN Map")
    If Range("G66:G81") >= 0.181 Then
        ActiveSheet.Shapes.Range(Array("Barnstable", "Belknap", "Cheshire", "Dukes", "Essex", "Hillsborough", "Merrimack", "Middlesex", "Nantucket", "Norfolk", "Plymouth", "Rockingham", "Strafford", "Suffolk", "Windham", "Worcester").Fill.ForeColor.RGB = RGB(189, 0, 38)).Transparency = 0.1999999881
    End If
    Next
    
End Sub

[code]

 

[RickXL]

Hi and welcome to the MrExcel Message Board.

Your code was quite creative. I have taken a guess and I think you are trying to do something like this:

Option Base 1

Sub WBINmap()
    ' WBINmap Macro
    Dim arr  As Variant
    Dim i    As Long
    Dim Clr  As Long

    arr = Array("Barnstable", "Belknap", "Cheshire", "Dukes", "Essex", _
            "Hillsborough", "Merrimack", "Middlesex", "Nantucket", "Norfolk", _
            "Plymouth", "Rockingham", "Strafford", "Suffolk", "Windham", "Worcester")
    
    With ThisWorkbook.Sheets("WBIN Map")
        For i = 1 To 16
            Select Case IIf(.Range("G106:G121")(i) < 0, 0, .Range("G66:G81")(i))
                Case 0:          Clr = RGB(192, 192, 192)
                Case Is <= 0.01: Clr = RGB(255, 255, 178)
                Case Is <= 0.05: Clr = RGB(254, 204, 92)
                Case Is <= 0.1:  Clr = RGB(253, 141, 60)
                Case Is <= 0.18: Clr = RGB(240, 59, 32)
                Case Else:       Clr = RGB(255, 255, 255)
            End Select
            With .Shapes(arr(i))
                .Fill.Transparency = 0.1999999881
                .Fill.ForeColor.RGB = Clr
            End With
        Next
    End With
End Sub

I have assigned the Array to a variable. The Array has elements numbered from 1 to 16. That is what the "Option 1" is for.
I also assumed that everything applies to worksheet "WBIN Map".
The IIF statement is so that one Select Case statement can be used for both criteria.
I have removed the numeric ranges and changed them to an upper limit. I hope that is OK?

I tried it with some random numbers with all the Shapes hexagons and it looked quite good.

Nearly forgot, If the value is over 0.18 the Shape is coloured White. You can change that (Case Else).

Regards,

 

[slk927]

Hi and welcome to the MrExcel Message Board.

Your code was quite creative. I have taken a guess and I think you are trying to do something like this:

Option Base 1

Sub WBINmap()
    ' WBINmap Macro
    Dim arr  As Variant
    Dim i    As Long
    Dim Clr  As Long

    arr = Array("Barnstable", "Belknap", "Cheshire", "Dukes", "Essex", _
            "Hillsborough", "Merrimack", "Middlesex", "Nantucket", "Norfolk", _
            "Plymouth", "Rockingham", "Strafford", "Suffolk", "Windham", "Worcester")
    
    With ThisWorkbook.Sheets("WBIN Map")
        For i = 1 To 16
            Select Case IIf(.Range("G106:G121")(i) < 0, 0, .Range("G66:G81")(i))
                Case 0:          Clr = RGB(192, 192, 192)
                Case Is <= 0.01: Clr = RGB(255, 255, 178)
                Case Is <= 0.05: Clr = RGB(254, 204, 92)
                Case Is <= 0.1:  Clr = RGB(253, 141, 60)
                Case Is <= 0.18: Clr = RGB(240, 59, 32)
                Case Else:       Clr = RGB(255, 255, 255)
            End Select
            With .Shapes(arr(i))
                .Fill.Transparency = 0.1999999881
                .Fill.ForeColor.RGB = Clr
            End With
        Next
    End With
End Sub

I have assigned the Array to a variable. The Array has elements numbered from 1 to 16. That is what the "Option 1" is for.
I also assumed that everything applies to worksheet "WBIN Map".
The IIF statement is so that one Select Case statement can be used for both criteria.
I have removed the numeric ranges and changed them to an upper limit. I hope that is OK?

I tried it with some random numbers with all the Shapes hexagons and it looked quite good.

Nearly forgot, If the value is over 0.18 the Shape is coloured White. You can change that (Case Else).

Regards,

Thank you so much for your help!! You saying my code was "quite creative" was very generous
So I used your code in my map, but all the shapes turn the gray color (reading only Case 0, i'm assuming?) and when clicking on the various slicer options which are linked to the shapes' cell values and change depending on the slections, all shapes remain gray regardless if they are 0 or 0.23.
I'm following your code for the most part, but can you explain the G66:G81 range? In my workbook, there are no values in those cells so not sure what it's referencing?
Again, thank you for your help!

 

[RickXL]

I got the range from your original post.

If Range("G66:G81") = 0.001 - 0.01 Then

 

[RickXL]

This is the code if you are using only one range for the data:

Sub WBINmap()
    ' WBINmap Macro
    Dim arr  As Variant
    Dim i    As Long
    Dim Clr  As Long

    arr = Array("Barnstable", "Belknap", "Cheshire", "Dukes", "Essex", _
            "Hillsborough", "Merrimack", "Middlesex", "Nantucket", "Norfolk", _
            "Plymouth", "Rockingham", "Strafford", "Suffolk", "Windham", "Worcester")
    
    With ThisWorkbook.Sheets("WBIN Map")
        For i = 1 To 16
            Select Case .Range("G106:G121")(i)
                Case Is <= 0:    Clr = RGB(192, 192, 192)
                Case Is <= 0.01: Clr = RGB(255, 255, 178)
                Case Is <= 0.05: Clr = RGB(254, 204, 92)
                Case Is <= 0.1:  Clr = RGB(253, 141, 60)
                Case Is <= 0.18: Clr = RGB(240, 59, 32)
                Case Else:       Clr = RGB(255, 255, 255)
            End Select
            With .Shapes(arr(i))
                .Fill.Transparency = 0.1999999881
                .Fill.ForeColor.RGB = Clr
            End With
        Next
    End With
End Sub

 

[slk927]

Ah, yes. That indeed was in my original code. n00b error as I forgot to update the ranges originally thank you for pointing that out!
and THANK YOU for this! Map color codes correctly and looks great

one last question, hopefully. If I wanted the map to automatically update whenever the cell value is changed via a slicer, would I use something of the sort below?
attempted this type of code before posting too, which is why I had all those Ifs

<code style="margin: 0px; padding: 0px; border: 0px; font-family: Consolas, Menlo, Monaco, 'Lucida Console', 'Liberation Mono', 'DejaVu Sans Mono', 'Bitstream Vera Sans Mono', 'Courier New', monospace, sans-serif; white-space: inherit;">Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Me.Range("G106:G121")) Is Nothing Then Exit Sub
</code>

 

[RickXL]

I am not a Slicer expert but it seems to me that the PivotTableUpdate Event is triggered when Slicer options change a Pivottable. So this might work:

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
    Call WBINmap
End Sub

Note: That needs to be placed in the code module for the worksheet with the PivotTable not in an ordinary Module.

 

[slk927]

You are a genius!!!! This was preciously what I was looking for! Thank you, sir! Works like a charm.
In regards to the "Call WBINmap" part of the code, just wondering why the syntax doesn't require a space between "WBIN" and "map" ?

 

[RickXL]

You are a genius!!!!

Agreed, but a minority view, unfortunately. Just you and me, in fact.

... just wondering why the syntax doesn't require a space between "WBIN" and "map" ?

The routine is calling the macro and not the worksheet.

I am pleased we got it working. Shapes are fun.

Regards,