Wykresy na mapie Polski w VBA

Obejrzałem bardzo ciekawą prezentację nt. tworzenia wykresów na mapie Polski. https://www.youtube.com/watch?v=sURKmfpDujE

Poniżej wersja VBA, która znalazła się w moich narzędziach. Przyznaję, że jest to zlepek wielu makr i efekt moich mniej lub bardziej świadomych eksperymentów. Na razie działa ale pewno wymaga udoskonaleń.
W pliku Excel mam dwie zakładki "DaneDoMapy" i "Map"
Na podstawie danych do mapy  (tabelka z kolumną x z nazwą dla każdego wykresu i np. dwie kolumny danych do wykresu słupkowego w każdym województwie) zostaną stworzone wykresy słupkowe i umieszczone we właściwym miejscu na mapie.

Sub main()
Sub main()
   'variable declaration
    Dim i As Long
    Dim LastRow As Long
    Dim LastColumn As Long
    Dim chrt As Chart
    Dim MaxValue As Double
    Dim ChartName As Style
    
   
    
     'Clean Sheet
    Sheets("Wykresy").DrawingObjects.Delete

    'Find the last used row
    LastRow = Sheets("DaneDoMapy").Range("A65536").End(xlUp).Row

    'Find the last used column
    LastColumn = Sheets("DaneDoMapy").Range("A1").End(xlToRight).Column

    'Find MaxValue
    MaxValue = 1.4 * Application.WorksheetFunction.Max(Sheets("DaneDoMapy").UsedRange)

    


    'Looping from second row till last row which has the data
    For i = 2 To LastRow
    

        
        'Sheet 2 is selected bcoz charts will be inserted here
        Sheets("Wykresy").Activate

        'Adds chart to the sheet
        Set chrt = Sheets("Wykresy").Shapes.AddChart.Chart
        
        
        'sets the chart type
        With chrt
             .ChartType = xlColumnClustered
             .Axes(xlValue).MajorGridlines.Delete
             .Axes(xlValue).Delete
             .Legend.Delete
             .PlotArea.Fill.Visible = False

       '      .Axes(xlCategory).Delete
 

        'scale
             .Axes(xlValue).MinimumScale = 0
             .Axes(xlValue).MaximumScale = MaxValue
            
        'size
             .Parent.Height = 100 ' resize 2.5 pt at 72 ppi.
             .Parent.Width = 45 ' resize 4.0 pt at 72 ppi.
             
  

        End With




        'now the line chart is added...setting its data source here
        With Sheets("DaneDoMapy")
            chrt.SetSourceData Source:=.Range(.Cells(i, 1), .Cells(i, LastColumn))
            chrt.Parent.Name = Left(Worksheets("DaneDoMapy").Cells(i, 1).Text, 3)
        End With

        'Left & top are used to adjust the position of chart on sheet
        chrt.ChartArea.Left = 1
        chrt.ChartArea.Top = (i - 2) * chrt.ChartArea.Height

        'Last adjustments to chart
        With chrt
            .ChartTitle.Font.Size = 7
            .ChartTitle.Font.Bold = True
            .ChartTitle.Font.Name = "Tahoma"
          '  .ChartTitle.Left = -(.ChartTitle.Left / 2)
             .ChartTitle.Top = -7 '-(.Parent.Height / 2)
    
  
        
        
        End With
  
  'set x axis
  
        
    With Sheets("DaneDoMapy")
       chrt.SeriesCollection(1).XValues = .Range(.Cells(1, 2), .Cells(1, LastColumn))
       chrt.Axes(xlCategory).TickLabels.Font.Name = "Arial Narrow"
       chrt.Axes(xlCategory).TickLabels.Font.Size = 6
       chrt.Axes(xlCategory).TickLabels.Orientation = 0
    End With
        
  'Change colors
               With chrt.SeriesCollection(1)
                         
                         .Points(1).Interior.Color = RGB(0, 0, 255)
                         .Points(2).Interior.Color = RGB(255, 0, 0)


                End With


        
        
        Next

 '       AddDataLabels_All
        FormatShapes
        PlaceOnMap
        AddDataLabels_All
End Sub






Sub FormatShapes()
    
         Dim iChtIx As Long, iChtCt As Long


         iChtCt = ActiveSheet.Shapes.Count
         For iChtIx = 1 To iChtCt
             With ActiveSheet.Shapes(iChtIx)
                .Fill.Visible = msoFalse
                .Line.Visible = msoFalse
             End With
         Next
End Sub





Sub AddDataLabels_All()

    Dim sr As Series
    Dim ws As Worksheet
    Dim chtObj As ChartObject

    Set ws = Worksheets("Map")
        For Each chtObj In ws.ChartObjects
            For Each sr In chtObj.Chart.SeriesCollection

                sr.ApplyDataLabels
                With sr.DataLabels
                    .ShowSeriesName = False
                    .ShowValue = True
                    .Position = xlLabelPositionOutsideEnd
                    .Orientation = 90
                    .Font.Size = 7
                    .Font.Name = "Tahoma"
                    .NumberFormat = "#,##0.00,, \m" '"# ###.#, k" - if in thousands
                End With

            Next sr
       Next chtObj

End Sub


Sub PlaceOnMap()


Sheets("Map").Activate
'Sheets("Map").DrawingObjects.Delete

On Error Resume Next

Sheets("Map").ChartObjects("BIA").Delete
Sheets("Map").ChartObjects("BYD").Delete
Sheets("Map").ChartObjects("GDA").Delete
Sheets("Map").ChartObjects("GOW").Delete
Sheets("Map").ChartObjects("KAT").Delete
Sheets("Map").ChartObjects("KIE").Delete
Sheets("Map").ChartObjects("KRA").Delete
Sheets("Map").ChartObjects("LDZ").Delete
Sheets("Map").ChartObjects("LUB").Delete
Sheets("Map").ChartObjects("OLS").Delete
Sheets("Map").ChartObjects("OPO").Delete
Sheets("Map").ChartObjects("POZ").Delete
Sheets("Map").ChartObjects("RZE").Delete
Sheets("Map").ChartObjects("SZC").Delete
Sheets("Map").ChartObjects("WAW").Delete
Sheets("Map").ChartObjects("WRO").Delete

    Sheets("Wykresy").ChartObjects("BIA").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("BIA")
        .Left = 410
        .Top = 70

    End With

    Sheets("Wykresy").ChartObjects("BYD").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("BYD")
        .Left = 195
        .Top = 95

    End With


    Sheets("Wykresy").ChartObjects("GDA").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("GDA")
        .Left = 160
        .Top = 5

    End With


    Sheets("Wykresy").ChartObjects("GOW").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("GOW")
        .Left = 38
        .Top = 160

    End With


    Sheets("Wykresy").ChartObjects("KAT").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("KAT")
        .Left = 215
        .Top = 310

    End With

DoEvents 'lets the operating system clear / execute any backed up / queued events that it might have to execute.
'slow down the execution (to not get an error)
ThisWorkbook.Save
Application.CutCopyMode = False





    Sheets("Wykresy").ChartObjects("KIE").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("KIE")
        .Left = 300
        .Top = 280

    End With

    Sheets("Wykresy").ChartObjects("KRA").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("KRA")
        .Left = 265
        .Top = 350

    End With

    Sheets("Wykresy").ChartObjects("LDZ").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("LDZ")
        .Left = 230
        .Top = 210

    End With

    Sheets("Wykresy").ChartObjects("LUB").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("LUB")
        .Left = 410
        .Top = 230

    End With
    
    Sheets("Wykresy").ChartObjects("OLS").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("OLS")
        .Left = 275
        .Top = 40

    End With
    
DoEvents 'lets the operating system clear / execute any backed up / queued events that it might have to execute.
'slow down the execution (to not get an error)
ThisWorkbook.Save
    
Application.CutCopyMode = False
    

    Sheets("Wykresy").ChartObjects("OPO").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("OPO")
        .Left = 160
        .Top = 290

    End With


    Sheets("Wykresy").ChartObjects("POZ").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("POZ")
        .Left = 120
        .Top = 140

    End With


    Sheets("Wykresy").ChartObjects("RZE").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("RZE")
        .Left = 370
        .Top = 340

    End With


    Sheets("Wykresy").ChartObjects("SZC").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("SZC")
        .Left = 60
        .Top = 45

    End With


    Sheets("Wykresy").ChartObjects("WAW").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("WAW")
        .Left = 320
        .Top = 155

    End With



    Sheets("Wykresy").ChartObjects("WRO").Cut
    Sheets("Map").Paste

    With Sheets("Map").Shapes("WRO")
        .Left = 95
        .Top = 255

  Application.CutCopyMode = False

    End With

DoEvents 'lets the operating system clear / execute any backed up / queued events that it might have to execute.
'slow down the execution (to not get an error)
ThisWorkbook.Save

End Sub

Przykładowy plik tutaj.

Polecam również bardzo ciekawe artykuły tutaj: http://www.apocotenexcel.pl/mapa2.htm http://www.wiseowl.co.uk/blog/s130/excel-charts-data-labels-problem.htm https://support.microsoft.com/en-us/kb/914813