HeatMap XL cleaner VB code

[Stephan]

XL UK HeatMap attached looks & works great.

But VB 1st Module macro1, can this be more concise?

Sub Edit1()
Sheets("Dash").Select
Application.ScreenUpdating = False
Dim Sub13 As Integer
Dim Sub21 As Integer
Dim Sub19 As Boolean
Dim Sub16111 As Integer
'just a little scrable
Dim Sub12 As Integer
Dim Sub24 As String
Dim Sub20 As Variant
Dim Sub15 As Integer
Dim Sub17 As String
Dim Sub16 As Integer
Dim Sub18 As Double
Dim Sub23 As Integer
Dim Sub14 As Integer
Dim i As Integer
Dim iTotal As Integer

Sub19 = False
Sub23 = Sub13
Sub12 = 1
Sub14 = 16
Sub13 = 15
Sub20 = Range("data").Value
Sub16 = Sub12 + (Sub13 / Sub12)
Dim Sub22 As String
Sub21 = Sub16
For Sub15 = Sub12 To UBound(Sub20)
Sub17 = Sub20(Sub15, Sub12)
Sub18 = Sub20(Sub15, Sub12 + Sub14 - Sub13)
If (Sub19 = False Or Sub17 = "DASH") Then
Edit2 Sub17, Sub18
Else
On Error Resume Next
ActiveSheet.Shapes("S_" & Sub17).Delete
On Error GoTo 0
End If
Next Sub15
DoEvents
Application.ScreenUpdating = False
DoEvents
For Sub15 = Sub12 To Sub16
Range("scale" & Sub15).Interior.color = Range("color" & Sub15).Interior.color
Next Sub15
i = Sub12 + Sub12 + Sub12
iTotal = Sub14 - Sub13
Do While i > 5 * (Sub14 - Sub13)
iTotal = i + iTotal
i = i - Sub12
Loop
End Sub
Sub Edit2(Sub6 As String, Sub9 As Double)
Dim Sub7 As Integer
Dim Sub5 As Long
Dim Sub11 As String
Dim Sub10
Dim Sub8 As Variant
Application.ScreenUpdating = False
Sub8 = Range("scales").Value
For Sub7 = UBound(Sub8) To 1 Step -1
If (Sub9 >= Sub8(Sub7, 1) Or Sub7 = 1) Then
Sub5 = Range("color" & Sub7).Interior.color
Sub7 = -1
End If
Next Sub7
Edit3 "S_" & Sub6, Sub5
Application.ScreenUpdating = False
End Sub
Sub Edit3(Sub1 As String, Sub4 As Long)
Dim Sub2 As Double
Dim Sub3 As Double
Application.ScreenUpdating = False
On Error GoTo ending
ActiveSheet.Shapes(Sub1).Select
Application.ScreenUpdating = False
Sub3 = Range("transparency").Value / 100
ActiveSheet.Shapes(Sub1).Fill.Solid
ActiveSheet.Shapes(Sub1).Fill.ForeColor.RGB = Sub4
ActiveSheet.Shapes(Sub1).Fill.transparency = Sub3
ActiveSheet.Shapes(Sub1).Fill.Visible = msoTrue
Sub2 = 1
If (Sub2 > 0#) Then
ActiveSheet.Shapes(Sub1).Line.Weight = Sub2
ActiveSheet.Shapes(Sub1).Line.DashStyle = msoLineSolid
ActiveSheet.Shapes(Sub1).Line.Style = msoLineSingle
ActiveSheet.Shapes(Sub1).Line.ForeColor.RGB = RGB(75, 75, 75)
ActiveSheet.Shapes(Sub1).Line.Visible = msoTrue
Else
ActiveSheet.Shapes(Sub1).Line.Visible = msoFalse
End If
ending:
End Sub
Sub Edit4()
Application.ScreenUpdating = False
End Sub

 

[Stephan]

added more functions to file, UK HeatMap now includes refresh/update on selection of Combo Categories, of tab DASH cell B1 via macro. Btm combo is total per area of category.

Note: Data is ficitious/rand generated, hence not accurate or true.

Hard to find decent COUNTRY MAP image files of UK counties/cities in required SVG file, haven't found any free 1's that once opened in XL as XML still contained area name in ID3 for copy & paste, and of those edited to EMF some did not ungroup into individual area segments.

Explained in detail here:
http://www.clearlyandsimply.com/cle...uild-your-own-choropleth-maps-with-excel.html

Perhaps more USA maps or overall EUROPE maps are free & complete SVG files that when opened in XL still have area names, and once coverted from SVG > EMF via InkScape then Inserted into XL will ungroup as intended, then use macro below to rename "freeform" shapes to certain "area name".

Option Explicit

Sub GetShapeNames()
Dim shp As Shape
Dim i As Long

i = 1
For Each shp In ActiveSheet.Shapes
ActiveSheet.Range("M1").Offset(i, 0).Value = _
ActiveSheet.Shapes(i).Name
i = i + 1
Next shp

End Sub

Sub SetShapeNames()
Dim shp As Shape
Dim i As Long

i = 1
For Each shp In ActiveSheet.Shapes
ActiveSheet.Shapes(i).Name = _
ActiveSheet.Range("N1").Offset(i, 0).Value
i = i + 1
Next shp

End Sub