Hi all,
I created a dashboard with a map of Japan that automatically visualises trends based on the data metric selected. Though, I want to keep all prefectures/provinces coloured 'black' with a white outline if there is NO data available. As an example, for the population data all prefectures have data available and should does be coloured accordingly, though, products aren't sold in all of them, thus, only the ones where data is available should be coloured. Currently it would colour them in the lightest colour (based on the legend defined)...
This is the code I am using:
Sub UpdateJapanColorScale()
' Update the RGB values and the colors of the legend after changing the color scale on worksheet [control]
Dim i As Integer
Dim rngJapan_MapValueToColor As Range
Dim rngColorScales As Range
Dim rngColorScaleSelection As Range
Dim rngLegend As Range
Dim myCell As Range
' Initialize
Application.ScreenUpdating = False
If Range("Selected_View").Value = 1 Then
Set rngJapan_MapValueToColor = Range("Japan_MapValueToColor").Offset(0, 1).Resize(Range("Japan_MapValueToColor").Rows.Count, 1)
Set rngColorScales = Range("Japan_myColorScales")
Set rngColorScaleSelection = Range("Japan_myColorScaleSelection")
Set rngLegend = Range("Japan_myLegend")
' Loop through the defined color scale and write the RGB values to the [control] sheet / format the legend cells on the map
For i = 1 To rngJapan_MapValueToColor.Rows.Count
rngJapan_MapValueToColor(i, 1) = rngColorScales(i, rngColorScaleSelection.Value).Interior.Color
rngLegend(i, 1).Interior.Color = rngColorScales(i, rngColorScaleSelection.Value).Interior.Color
Next i
For Each myCell In Range("Japan_MapNameToShape").Columns(1).Cells
CheckColor Range(myCell.Value), "Japan_MapNameToShape", "Japan_MapValueToColor"
Next myCell
Set rngJapan_MapValueToColor = Nothing
Set rngColorScales = Nothing
Set rngColorScaleSelection = Nothing
Set rngLegend = Nothing
Application.ScreenUpdating = True
End If
If Range("Selected_View").Value = 2 Then
Set rngJapan_MapValueToColor = Range("Japan_MapValueToColor").Offset(0, 1).Resize(Range("Japan_MapValueToColor").Rows.Count, 1)
Set rngColorScales = Range("JapanVAR_myColorScales")
Set rngLegend = Range("Japan_myLegend")
' Loop through the defined color scale and write the RGB values to the [control] sheet / format the legend cells on the map
For i = 1 To rngJapan_MapValueToColor.Rows.Count
rngJapan_MapValueToColor(i, 1) = rngColorScales(i, 1).Interior.Color
rngLegend(i, 1).Interior.Color = rngColorScales(i, 1).Interior.Color
Next i
' Update the map to apply the new color to the choropleth map
For Each myCell In Range("Japan_MapNameToShape").Columns(1).Cells
CheckColor Range(myCell.Value), "Japan_MapNameToShape", "Japan_MapValueToColor"
Next myCell
' Clean Up
Set rngJapan_MapValueToColor = Nothing
Set rngColorScales = Nothing
Set rngLegend = Nothing
Application.ScreenUpdating = True
End If
End Sub
I would assume this could be fixed with a 'simple' If statement somewhere in between the lines of code?
japan map forum.PNG
Bookmarks