Inny sposób prezentowania danych na mapie   strona główna:
A po co ten Excel ;-)
 
Zadanie jak w temacie.. Mamy pewne dane statystyczne i chcemy je zaprezentować na mapie..  
    Pewnym rozwiązaniem będzie utworzenie wykresu XY w którym tłem będzie nasza mapa, a w określonych punktach X,Y w jakiś  
sposób zaprezentujemy nasze dane.    przykład takiej mapy na
excelforum.pl
 
    Ja chciałem do sprawy podejść zupełnie inaczej..  
Mamy dane dotyczące np.: gęstości zaludnienia czy urbanizacji dla poszczególnych powiatów z całej Polski. Mając mapę polski chcę   UserForm Painting By
SetPixel Function
pomalować poszczególne powiaty na odpowiedni kolor w określonej skali. Realizacja zadania w takie sposób nawet nie przyszła by mi  
do głowy gdyby nie przykłady "Rysowania po UserFormie" wykorzystując funkcje GetPixel, SetPixel..  
 
Na początku będzie nam potrzebna mapa na której każdy powiat będzie pomalowany innym kolorem, mało tego, musimy wiedzieć jaka   Mapa polski
excelforum.pl
kombinacja barw RGB została wykorzystana do jej pokolorowania. Mapę które się posłużyłem pokazał kiedyś na excelforum.pl J_B  
 
    Mamy więc mapę i informacje o tym jakie kolory zostały użyte do pokolorowania poszczególnych powiatów. Teraz teoria jest taka:  
W pętli przeglądnę mapę czytając kolor danego pixela. Sprawdzę z jakich składowych zbudowany został dany koloru i znając składowe  
określę "nad którym" powiatem jestem. Wiedząc jaka wartość danej statystycznej określa dany powiat i wiedząc "w którym miejscu"  
pomiędzy min a max dla wartości tych danych dany powiat się znajduje mogę nadać temu pixelowi inny kolor zgodny ze pozycją  
na określonej przez nas skali kolorów…  
    Trochu roboty nas zatem czeka :-)  
 
Najpierw zajmijmy się skalą kolorów jaką przyjmiemy do kolorowania poszczególnych elementów mapy..  
    Wymyśliłem to tak:
 
Będą dwie skale kolorów. Weźmy np.: dane o gęstości zaludnienia  
Min dla kolor1 to =MIN(JEŻELI(dane<>0;dane;"")) tablicowo..  
Max dla kolor2 to =MAX(dane)  
    Czemu to min ma warunek? Bo mogę pewnych danych po prostu nie mieć, a   
nie chcę żeby wartość min dla koloru1 była = 0 gdyż obszar o najmniejszej   
gęstości zaludnienia nie miałby nadanego koloru dla min.  
I cała skala byłaby niepotrzebnie "spłaszczona".  
    Max dla koloru1 to wartość jaką sami wskażemy według własnych potrzeb.  
Ważne jest że wszystko powyżej tej wartości znajdzie się w skali drugiego  
koloru.  
    Min dla kolor2 to max dla kolor1 + 0,01. Jasne :-)  
 
    Jednak choć całość wygląda nieźle to jak działa? Mamy składowe dla każdego koloru (R,G,B) i ich wartości ale jak pokazać kolor  
o takich składowych? Można taki kolor zwrócić funkcją :-) Poważnie!  
 
Function LabelRGB(xlLabelName As String, R As Integer, G As Integer, B As Integer)  
    Dim xlShp As Excel.Shape  
      
    With Application.Caller.MergeArea  
        On Error Resume Next  
        .Parent.Shapes(xlLabelName).Delete  
        On Error GoTo 0  
 
        Set xlShp = .Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, .Left, .Top, .Width, .Height)  
    End With  
      
    With xlShp  
        .Name = xlLabelName  
        .Fill.ForeColor.RGB = VBA.RGB(R, G, B)  
    End With  
    Set xlShp = Nothing  
End Function  
 
Jak się przekonacie w komórce poniżej składowych dla danego koloru znajduje się formuła np: =LabelRGB("labMinK1";G6;H6;I6)  
Formuła, do komórki w której się znajduje wstawi obiekt Shape i nada mu odpowiedni kolory wypełnienia.  
   
Tak na marginesie:  
Jest taka fajna ramka na 265 stronie książeki: "Excel 2003PL. Programowanie w VBA. J.Walkenbach"  
 
    "Czego niestandardowe funkcje arkusza nie potrafią?  
Jeżeli tworzysz niestandardową funkcję, musisz rozumieć kluczową róznicę między funkcjami wywoływanymi z innych procedur  
języka VBA i funkcjami stosowanymi w formułach arkusza. Procedury Function w formułach muszą być pasywne (…) Należy  
pamiętać o tym, że funkcja jedynie zwraca wartość (lub tablicę wartości) i nie potrafi wykonywać operacji na obiektach."  
 
W każdej książce nt VBA w temtatyce "różnica między Sub i Function" znajdziecie podobne stwierdzenie. I nie piszę tego żeby to    inne funkcje działające na shape:
zdanie podważyć ;-) Jedynie powiedzieć że od tej reguły istnieją wyjątki. I praca z obiektami Shape jest właśnie takim wyjątkiem.   OBRAZ (wstawianie-zdjecia)
    ShapeRotation (obracanie obiektu)
 
Funkcję LabelRGB wykorzystam jeszcze do jednej rzeczy..
 
    Same "graniczne" kolory nie dadzą nam jeszcze ogólnego pojęcia  
o wyglądzie skali kolorów jaką wykorzystamy.  
    Pytanie jednak brzmi? Jaką formułę napisać żeby zwróciła wartości  
składowych pomiędzy kolorami granicznymi?  
Nie jest to bynajmniej nie istotne bo poznanie tego mechanizmu  
pozwoli nam określić składowe koloru którym "kolorujemy" dany  
powiat względem wartości dla niego a min i max dla danych.  
Łatwiej taką formułę napisać w arkuszu a dopiero później "ubrać" to   
w kod VBA :-)  
 
=JEŻELI((J$6-G$6)=0;J$6;JEŻELI((J$6-G$6)>0;  
G$6+(J$6-G$6)*(0,05*$T7);J$6+(G$6-J$6)*(1-0,05*$T7)))  
 
J6 to max dla kolor1, G6 to min dla kolor1  
- JEŻELI((J$6-G$6)=0;J$6 - jeżeli max i min są takie same to wartość  
                                     max (lub min) będzie niezmienne dla całej  
                                     skali.  
- JEŻELI((J$6-G$6)>0; G$6+(J$6-G$6)*(0,05*$T7) - jeżeli max jest większe od min (co dla każdej wartości składowych nie jest  
                                                                       regułą) to min minus róznica między max a min pomnożone przez dany procent  
                                                                       określi wartości dla skali. Np.: max to 250, min to 150. Wartości na skali będą  
                                                                       zawierać się pomiędzy 250 a 150 i będą coraz większe dla większego proceutu.  
- ;J$6+(G$6-J$6)*(1-0,05*$T7)) - w przeciwnym razie: max mniejsze od min. Wartości będą maleć wraz ze wzrostem procętu  
 
Mając te dane możemy przystąpic do pracy przy UserForm'ie..  
 - mapę wstawiłem jako Picture UserForm'a  
 - po załadowaniu formy klikamy na przycisk "Maluj"  
 
 
Sub Maluj()  
    bSave = False  
    Dim lngPixelColor As Long  
    Dim R As Integer, G As Integer, B As Integer  
    Dim frmHdc As Long  
      
    Const odh As Single = 0.748  
      
    On Error GoTo handleCancel  
    Application.EnableCancelKey = xlErrorHandler  
      
    Dim iPix As Single, jPix As Single  
    Dim lngColor As Long: lngColor = 0  
      
    Dim xlWks As Excel.Worksheet, dblWart As Double  
      
    Set xlWks = ThisWorkbook.Worksheets("Arkusz1")  
    With xlWks  
        Dim tblGR As Variant, tblDane As Variant  
        Dim dblMax1 As Double, dblMax2 As Double  
      
        tblGR = .[A2:B380]: tblDane = .[E2:E380]  
        dblMax2 = .[Q4]: dblMax1 = .[J4]  
          
        Dim Rmin1 As Integer, Gmin1 As Integer, Bmin1 As Integer  
        Dim Rmax1 As Integer, Gmax1 As Integer, Bmax1 As Integer  
        Dim Rmin2 As Integer, Gmin2 As Integer, Bmin2 As Integer  
        Dim Rmax2 As Integer, Gmax2 As Integer, Bmax2 As Integer  
          
        UnRGB .Shapes("labMinK1").Fill.ForeColor.RGB, Rmin1, Gmin1, Bmin1  
        UnRGB .Shapes("labMaxK1").Fill.ForeColor.RGB, Rmax1, Gmax1, Bmax1  
        UnRGB .Shapes("labMinK2").Fill.ForeColor.RGB, Rmin2, Gmin2, Bmin2  
        UnRGB .Shapes("labMaxK2").Fill.ForeColor.RGB, Rmax2, Gmax2, Bmax2  
          
        Dim xR As Integer, xG As Integer, xB As Integer  
        Dim bFalg As Boolean  
          
    End With  
      
    frmHdc = FormHDC  
      
    Const pixel2point As Single = 0.748  
      
    With Me  
        .CommandButton1.Top = 500  
        .Repaint  
        For iPix = 1 To .Width Step pixel2point  
            For jPix = 1 To .Height Step pixel2point  
              
                  
                lngPixelColor = GetPixel(frmHdc, iPix / odh, jPix / odh)  
                UnRGB lngPixelColor, R, G, B  
    
                If R Mod 5 = 0 And G Mod 5 = 0 And B Mod 5 = 0 Then  
                    'With xlWks  
                        dblWart = WartDlaPowiatu(G, R, tblGR, tblDane)  
                          
                        If dblWart > 0 Then  
                            If Not bFalg Then: If jPix > Me.Width - 50 Then bFalg = True  
                            If dblWart > xlWks.[J4] Then  
                                'kolor2  
                                Select Case Rmax2 - Rmin2  
                                    Case 0: xR = Rmax2  
                                    Case Is > 0: xR = CInt(Rmin2 + (Rmax2 - Rmin2) * dblWart / dblMax2)  
                                    Case Is < 0: xR = CInt(Rmax2 + (Rmin2 - Rmax2) * (1 - dblWart / dblMax2))  
                                End Select  
                                Select Case Gmax2 - Gmin2  
                                    Case 0: xG = Gmax2  
                                    Case Is > 0: xG = CInt(Gmin2 + (Gmax2 - Gmin2) * dblWart / dblMax2)  
                                    Case Is < 0: xG = CInt(Gmax2 + (Gmin2 - Gmax2) * (1 - dblWart / dblMax2))  
                                End Select  
                                Select Case Bmax2 - Bmin2  
                                    Case 0: xB = Bmax2  
                                    Case Is > 0: xB = CInt(Bmin2 + (Bmax2 - Bmin2) * dblWart / dblMax2)  
                                    Case Is < 0: xB = CInt(Bmax2 + (Bmin2 - Bmax2) * (1 - dblWart / dblMax2))  
                                End Select  
                                lngColor = RGB(xR, xG, xB)  
                            Else  
                                If Not bFalg Then: If jPix > Me.Width - 50 Then bFalg = True  
                                'kolor1  
                                '=JEŻELI((J$6-G$6)=0;J$6; _  
                                  JEŻELI((J$6-G$6)>0;G$6+(J$6-G$6)*(0,05*$T7); _  
                                                     J$6+(G$6-J$6)*(1-0,05*$T7)))  
                                'J6 max; G6 min  
                                Select Case Rmax1 - Rmin1  
                                    Case 0: xR = Rmax1  
                                    Case Is > 0: xR = CInt(Rmin1 + (Rmax1 - Rmin1) * dblWart / dblMax1)  
                                    Case Is < 0: xR = CInt(Rmax1 + (Rmin1 - Rmax1) * (1 - dblWart / dblMax1))  
                                End Select  
                                Select Case Gmax1 - Gmin1  
                                    Case 0: xG = Gmax1  
                                    Case Is > 0: xG = CInt(Gmin1 + (Gmax1 - Gmin1) * dblWart / dblMax1)  
                                    Case Is < 0: xG = CInt(Gmax1 + (Gmin1 - Gmax1) * (1 - dblWart / dblMax1))  
                                End Select  
                                Select Case Bmax1 - Bmin1  
                                    Case 0: xB = Bmax1  
                                    Case Is > 0: xB = CInt(Bmin1 + (Bmax1 - Bmin1) * dblWart / dblMax1)  
                                    Case Is < 0: xB = CInt(Bmax1 + (Bmin1 - Bmax1) * (1 - dblWart / dblMax1))  
                                End Select  
                                lngColor = RGB(xR, xG, xB)  
                            End If  
                        Else  
                            If R <> 255 And B <> 255 Then  
                                lngColor = RGB(256, 256, 256)  
                            End If  
                        End If  
                    End With  
                End If  
                  
                If lngColor > 0 Then SetPixel frmHdc, iPix / odh, jPix / odh, lngColor  
                lngColor = 0  
            Next  
        Next  
        With .CommandButton1  
            .Top = 396  
            .Caption = IIf(bFalg, "Zapisz", "Maluj")  
        End With  
              
    End With  
      
    Exit Sub  
      
handleCancel:  
    If Err = 18 Then  
        MsgBox "Tworzenie mapy przerwane"  
        Unload Me  
    End If  
 
End Sub  
 
Fragmentami:  
 
    On Error GoTo handleCancel  
    Application.EnableCancelKey = xlErrorHandler  
 '…  
handleCancel:  
    If Err = 18 Then  
        MsgBox "Tworzenie mapy przerwane"  
        Unload Me  
    End If  
 
Jeżeli przerwiemy działąnie procedury poprzez Ctrl+Brake…  
 
    Set xlWks = ThisWorkbook.Worksheets("Arkusz1")  
    With xlWks  
        Dim tblGR As Variant, tblDane As Variant  
        Dim dblMax1 As Double, dblMax2 As Double  
      
        tblGR = .[A2:B380]: tblDane = .[E2:E380]  
        dblMax2 = .[Q4]: dblMax1 = .[J4]  
 
Do tablic tblGR i tblDane zostają zapisane wartości: tblGR to składowe koloru którymi poszczególne powiaty zostały pomalowane  
na pierwotnej mapie, tblDane to wartości jakie będziemy chcieli przedstawić na mapie w formie koloru ze skali. Te dane to np.:  
wspomniana gęstość zaludnienia. dblMax2 i dblMax1 to wartości maksymalne dla obu kolorów. Znając te wartości będziemy mogli  
powiedzieć jakim procentem danego Max jest wartość dla danego powiatu.  
 
        Dim Rmin1 As Integer, Gmin1 As Integer, Bmin1 As Integer  
        Dim Rmax1 As Integer, Gmax1 As Integer, Bmax1 As Integer  
        Dim Rmin2 As Integer, Gmin2 As Integer, Bmin2 As Integer  
        Dim Rmax2 As Integer, Gmax2 As Integer, Bmax2 As Integer  
          
        UnRGB .Shapes("labMinK1").Fill.ForeColor.RGB, Rmin1, Gmin1, Bmin1  
        UnRGB .Shapes("labMaxK1").Fill.ForeColor.RGB, Rmax1, Gmax1, Bmax1  
        UnRGB .Shapes("labMinK2").Fill.ForeColor.RGB, Rmin2, Gmin2, Bmin2  
        UnRGB .Shapes("labMaxK2").Fill.ForeColor.RGB, Rmax2, Gmax2, Bmax2  
 
Procedurą UnRGB wyciągamy składowe kolorów przez nas wybranych do zmiennych.. Procedura ta…  
 
Private Sub UnRGB(ByVal color As OLE_COLOR, _  
                  ByRef R As Integer, ByRef G As Integer, ByRef B As Integer)  
    R = color Mod 256  
    G = (color \ 256) Mod 256  
    B = color \ 65536  
End Sub  
 
Następnie określamy wartość dla FormHDC i zapisujemy ją do zmiennej:  
 
Function FormHDC() As Long  
    FormHDC = GetDC(FindWindow(vbNullString, Me.Caption))  
End Function  
 
Następnie:  
 
    Const pixel2point As Single = 0.748  
      
    With Me  
        For iPix = 1 To .Width Step pixel2point  
            For jPix = 1 To .Height Step pixel2point  
              
                lngPixelColor = GetPixel(frmHdc, iPix / odh, jPix / odh)  
                UnRGB lngPixelColor, R, G, B  
 
   Podwójną pętlą czytamy wszystkie pixele na naszej mapie. Ważny jest jednak krok pętli. Gdyby określić go np.: 1 (i więcej) mapa  
nie zostałaby pomalowana całkowicie. Pomalowany byłyby jedynie pojedyncze punkty na mapie oddalone od siebie proporcjonalnie do   
wielkości kroku. Gdyby wybrać wartość mniejszą niektóre elementy mapy byłyby czytanie więcej niż raz. Jednak drugi odczyt nie   
zwróciłby składowych które określiłyby jakikolwiek powiat. W konsekwencji punkt ten zostałby biały. A całość wyglądałaby jak kartka  
w kratkę: Mapa na białej kratce. Jedynie wartość 0,748 jest tu optymalna :-) Wynika to z faktu że mapa jest w pixelach a wielkość  
Userform'a w punktach trzeba więc przeliczyć pixel na point. Literatura na ten temat wskazuje na proporcję 72/96 (tj 0,75) jednak  
przy takiej wartości proporcji na mapie jeszcze mogą się pokazać niespodzianki.  
 
                If R Mod 5 = 0 And G Mod 5 = 0 And B Mod 5 = 0 Then  
 
Kolory zdefiniowane dla powiatów zostały taki nadawane żeby żadna skłądowa nie była podzielna w całości przez 5. To też jeżeli   
czytamy pixel który nie spełnia tego warunku to najprawdopodobniej nie jest to element mapy. Szkoda więc czasu na jego analizę.  
 
                        dblWart = WartDlaPowiatu(G, R, tblGR, tblDane)  
                          
                        If dblWart > 0 Then  
 
                        Else  
                            If R <> 255 And B <> 255 Then  
                                lngColor = RGB(256, 256, 256)  
                            End If  
                        End If  
 
odczytuję wartość dla powiatu. A więc: znając wartości G i R (składowe koloru elementu mapy)  szukam "numeru wiersza" tabliby  
tblGR i zwracam funkcją WartDlaPowiatu (trywialna) element tblDane odpowiadający temu wierszowi. Jeżeli wartość ta nie zostanie  
odczytana (=0) to danemu pixelowi nadamy kolor biały. Taki kolor zatem będą miały powiaty o których danych nie mamy.  
 
                        If dblWart > 0 Then  
                            If Not bFalg Then: If jPix > Me.Width - 50 Then bFalg = True  
                            If dblWart > xlWks.[J4] Then  
                                'kolor2  
                            Else  
                                If Not bFalg Then: If jPix > Me.Width - 50 Then bFalg = True  
                                'kolor1  
                            End If  
                        Else  
 
Jeżeli jednak odczytamy pewną wartość to musimy określić z którą skalą będziemy go porównywać.  
 
                            If Not bFalg Then: If jPix > Me.Width - 50 Then bFalg = True  
 
To jest pewien przełącznik który sprawdzi czy całość poszła OK. Po co? Bo Formularz lubi się wieszać :-| Zdarza się to częściej  
w wersjach Excela >2003 jednak reguły nie znam. U mnie (E2010 Win7) działa Zawsze za drigim razem :-|, ale działą :-P.  
Jednak chcę żeby mozliwość zapisania mapy jako Schape w Arkuszu była możliwa jeżeli procedura dojdzie do końca, w przeciwnym  
razie jedyna możliwość to odpalić procedurę jeszcze raz. Całość działa na jednym przycisku "Maluj/Zapisz" i po to mi ten przełącznik.  
Zauważyłem bowiem że jak się ma zawiesić to się zawiesi na początku. Jeżeli zatem jakiś pixcel pod koniec mapy zwróci wartość dla   
danego powiatu to całość przebiegła OK.  
    Czemu w ogóle dochodzi do "przywieszenia się" formy? Szczerze nie wiem. Pewnie jest jakiś błąd a stosując API błędy są wysoce  
niewskazane ;-) Jednak, jak pisałem za drugim razem u mnie działa, a błędu jakoś nie mogę zauważyć :-)  
 
                                Select Case Rmax2 - Rmin2  
                                    Case 0: xR = Rmax2  
                                    Case Is > 0: xR = CInt(Rmin2 + (Rmax2 - Rmin2) * dblWart / dblMax2)  
                                    Case Is < 0: xR = CInt(Rmax2 + (Rmin2 - Rmax2) * (1 - dblWart / dblMax2))  
                                End Select  
                                Select Case Gmax2 - Gmin2  
                                    Case 0: xG = Gmax2  
                                    Case Is > 0: xG = CInt(Gmin2 + (Gmax2 - Gmin2) * dblWart / dblMax2)  
                                    Case Is < 0: xG = CInt(Gmax2 + (Gmin2 - Gmax2) * (1 - dblWart / dblMax2))  
                                End Select  
                                Select Case Bmax2 - Bmin2  
                                    Case 0: xB = Bmax2  
                                    Case Is > 0: xB = CInt(Bmin2 + (Bmax2 - Bmin2) * dblWart / dblMax2)  
                                    Case Is < 0: xB = CInt(Bmax2 + (Bmin2 - Bmax2) * (1 - dblWart / dblMax2))  
                                End Select  
                                lngColor = RGB(xR, xG, xB)  
 
Tu jest nasza formuła ze skali danego koloru, tyle że w VBA.  
 
                If lngColor > 0 Then SetPixel frmHdc, iPix / odh, jPix / odh, lngColor  
                lngColor = 0  
 
Kolorowanie pixela na określony kolor..  
 
        With .CommandButton1  
            .Top = 396  
            .Caption = IIf(bFalg, "Zapisz", "Maluj")  
        End With  
 
I w zależności od faktu czy procedura doszła do końca czy nie …  
 
Pod tym przyciskiem:  
 
Private Sub CommandButton1_Click()  
    With Me.CommandButton1  
        If .Caption = "Maluj" Then  
            .Top = 500 'chowam przycisk   
            Me.Repaint  
            Maluj  
        ElseIf .Caption = "Zapisz" Then  
            .Top = 500  
            bSave = True  
            StartTimer  
        End If  
    End With  
End Sub  
 
Wyjaśnienie należy się jedynie sposobu zapisu..  
     Robię PrintScreen z aktywnego okna. Jednak wcześniej chciałbym schować przycisk. Me.Repaint resetnie Formularz a bez tego   
nie zdąże schować przycisku. Stwierdziłem że procedurę zapisu okrazu UserForma do schowka muszę wywołać tuż po zakończeniu  
zadań pod tym przyciskiem. Tak więc StartTimer..  
 
Public Declare Function SetTimer _  
    Lib "user32" ( _  
        ByVal hWnd As Long, _  
        ByVal nIDEvent As Long, _  
        ByVal uElapse As Long, _  
        ByVal lpTimerFunc As Long) _  
    As Long  
      
Public Declare Function KillTimer _  
    Lib "user32" ( _  
        ByVal hWnd As Long, _  
        ByVal nIDEvent As Long) _  
    As Long  
      
Public TimerId As Long  
 
Public Sub StartTimer()  
    On Error Resume Next  
    TimerId = SetTimer(0, 0, 500, AddressOf AltPrintScreen)  
    On Error GoTo 0  
End Sub  
Private Sub StopTimer()  
    On Error Resume Next  
    KillTimer 0, TimerId  
    On Error GoTo 0  
End Sub  
 
Procedura StartTimer zaplanuje wywołanie procedury AltPrintScreen po 500 milisekundach.  
 
Public Declare Sub keybd_event _  
    Lib "user32" ( _  
        ByVal bVk As Byte, _
 
        ByVal bScan As Byte, _  
        ByVal dwFlags As Long, _  
        ByVal dwExtraInfo As Long)  
 
Private Const KEYEVENTF_KEYUP = &H2  
Private Const VK_SNAPSHOT = &H2C  
Private Const VK_MENU = &H12  
 
Sub AltPrintScreen()  
    'How to do a screen capture using VBA  
    'http://word.mvps.org/FAQs/MacrosVBA/PrtSc.htm  
    keybd_event VK_MENU, 0, 0, 0  
    keybd_event VK_SNAPSHOT, 0, 0, 0  
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0  
    keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0  
    StopTimer  
End Sub  
 
I mamy obraz aktywnego okna (naszego "pokolorowanego" UserForm'a)   
w schowku :-) a stamtąd do arkusza już "prosta droga"  
ActiveSheet.Paste i jest:-)  
 
Dane nt: gęstości zaludnienia mam z Wikipedii.. Mapa gęstości zaludnienia   
wg tych danych wygląda następująco tak :-)  
(dwa białe powiaty - nie było danych - sorka :-P )  
 
 
 
 
 
 
 
 
 
 
                                                                                                    a dane nt. Urbanizacji :-)  
                                                                                                    kolor1 pomiędzy niebieskim a zielonym 0-60%   
                                                                                                    kolor2 pomiędzy żółtym a czerwonym 60,01-100%   
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
Jak utworzyć cłasną mapę z innymi danymi.  
-  Do zakresu E2:E380 wstawić swoje dane  
- określić skalę kolorów podając skłądowe dla min i max dla kolor1 i kolor2    
- odpalić UserForm i kliknąć przycisk "Maluj"   przykład można pobrać:
- w razie resetu formy (opisane wyżej) ponownie kliknąć "Maluj" (u mnie dzaiał zawsze za drugim razem)   Dane na mapie.zip
- jeżeli procedura dojdzie do końca kliknąć przycisk "zapisz". Zakmnąć Userform i kliknąć przycisk "zapisz obraz do arkusza"  
   
Sprinter to to nie jest, można śmiało rozwgrać partię domino z córcią czekając na wyniki, ale myslę że zaczekać warto :-)