Prezentacja rozrzutu wartości na podstawie danych na wykresie punktowym.   strona główna:
A po co ten Excel ;-)
 
 
 
     Niedawno walczyłem z fajnym tematem dotyczącym graficznej prezentacji   
rozrzutu danych zawartych na wykresie. Chciałbym zachować tu wyniki tej zabawy.  
     Mamy więc wykres punktowy pobierający dane z jakiegoś zakresu Arkusza.  
Niby jest to graficzna prezentacja danych jednak naszym zadaniem jest  
przedstawienie tych wartości w trochu inny sposób. A mianowicie…  
 
 
 
 
 
 
 
 
gdzie poszczególne elementy będą interpretowane jako  
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
Oczywiście takiego suwaka na podstawie danych z określonego wykresu nie zrobi za nas żaden automat. Ale od czego są TextBox'y  
:-) Tak!! To co widzicie to zestaw powiązanych w jedną grupę TextBoxów.  
 
Jak stworzyć takie coś?? Funkcją UDF :-) wpisaną do komórki/komórek Arkusza. Co prawda funkcji wystarczy jednak komórka ale  
wygląd naszego "wykresu" może nam nie odpowiadać z powodu jego rozmiarów. Dlatego najlepiej scalić kilka komórek zapewniając  
dostateczną ilość miejsca.  
 
Funkcja realizująca takie zadanie wmoże wyglądać np.: tak:  
 
Option Explicit  
 
Function WykresZLewej(dMin As Double, dMax As Double, _  
                      dNorma As Double, _  
                      xlLabelName As String, xlChrObjName As String)  
    Dim xlShp As Excel.Shape  
    Dim Q1 As Double, Q2 As Double, Q3 As Double:  
    Dim min As Double, max As Double  
    Dim arrElement, arrElemNames  
      
    Application.Volatile  
    With Application.Caller.MergeArea  
        On Error Resume Next  
        .Parent.Shapes(xlLabelName).Delete  
        On Error GoTo 0  
                  
        With .Parent.ChartObjects(xlChrObjName).Chart.SeriesCollection(1)  
            '--------------Kwartyle danych------------  
            Q1 = Application.Quartile(.Values, 1)  
            Q2 = Application.Quartile(.Values, 2)  
            Q3 = Application.Quartile(.Values, 3)  
            '--------------min i max Serii------------  
            min = Application.min(.Values)  
            max = Application.max(.Values)  
        End With  
        arrElement = VBA.Array(min, max, Q1, Q2, Q3)  
        arrElemNames = VBA.Array("min", "max", "Q1", "Q2", "Q3")  
 
        '---------------------linia główna-----------------  
        Dim xMin As Double: xMin = .Left + .Width * (min - dMin) / (dMax - dMin)  
        Dim xMax As Double: xMax = .Left + (.Width * (max - dMin) / (dMax - dMin)) - xMin  
        If xMin < .Left Then xMin = .Left  
        If xMax > .Left + .Width Then xMax = .Left + .Width  
        .Parent.Shapes.AddTextbox msoTextOrientationHorizontal, _  
                                  xMin, .Top + .Height / 2, _  
                                  xMax, 1  
          
 
        '---------------------linia pionowa---------------  
        Dim xSr As Double: xSr = .Left + .Width * (dNorma - dMin) / (dMax - dMin)  
        If xSr > .Left And xSr < .Left + .Width Then  
            .Parent.Shapes.AddTextbox msoTextOrientationHorizontal, _  
                                      xSr, .Top + .Height * 0.15, _  
                                      1, .Height - .Height * 0.3  
        End If  
        '---------------------tbox------------------------  
        Dim xTMin As Double: xTMin = .Left + .Width * (Q1 - dMin) / (dMax - dMin)  
        Dim xTMax As Double: xTMax = .Left + .Width * (Q3 - dMin) / (dMax - dMin) - xTMin  
        If xTMin < .Left Then xTMin = .Left  
        If xTMax > .Left + .Width Then xTMax = .Left + .Width  
        Set xlShp = .Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, _  
                                              xTMin, .Top + .Height * 0.33, _  
                                              xTMax, .Height - .Height * 0.66)  
        With xlShp  
            .Fill.ForeColor.RGB = VBA.RGB(178, 178, 178)  
            .Line.ForeColor.RGB = VBA.RGB(8, 8, 8)  
        End With  
        Set xlShp = Nothing  
        '---------------------tbox linia ------------------------  
        Dim xTSr As Double: xTSr = .Left + .Width * (Q2 - dMin) / (dMax - dMin)  
        If xTSr > .Left And xTSr < .Left + .Width Then  
            Set xlShp = .Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, _  
                                                  xTSr, _  
                                                  .Top + .Height * 0.33 - 2, _  
                                                  1, .Height - .Height * 0.66 + 4)  
            With xlShp  
                .Fill.ForeColor.RGB = VBA.RGB(8, 8, 8)  
                .Line.ForeColor.RGB = VBA.RGB(8, 8, 8)  
            End With  
            Set xlShp = Nothing  
        End If  
 
        '---------------------skala------------------------  
        Dim ii As Integer, xii As Double  
        For ii = Fix(dMin) + 1 To Fix(dMax)  
            xii = .Left + .Width * (ii - dMin) / (dMax - dMin) - 2  
            If xii > .Left And xii < .Left + .Width Then  
                Set xlShp = .Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, _  
                                                  xii, _  
                                                  .Top + .Height * 0.83 + 1, _  
                                                  8, .Height - .Height * 0.83 - 1)  
 
                With xlShp.TextFrame2  
                    .Parent.Line.Visible = msoFalse  
                    .MarginTop = 0  
                    .MarginLeft = 0  
                    .MarginRight = 0  
                    With .TextRange.Characters  
                        .Text = ii  
                        .Font.Size = 5  
      
                    End With  
                End With  
                Set xlShp = Nothing  
            End If  
        Next  
        '---------------------elementy------------------------  
        Dim dEmLeft As Double  
        For ii = 0 To 4  
            'Stop  
            dEmLeft = .Left + .Width * (arrElement(ii) - dMin) / (dMax - dMin) - 3  
            If dEmLeft > .Left And dEmLeft < .Left + .Width Then  
                Set xlShp = .Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, _  
                                                  dEmLeft, _  
                                                  .Top + .Height * 0.83 - 5, _  
                                                  10, .Height - .Height * 0.83 - 1)  
                  
                With xlShp.TextFrame2  
                    .Parent.Line.Visible = msoFalse  
                    .Parent.Fill.Transparency = 0.3  
                    .MarginTop = 0  
                    .MarginLeft = 0  
                    .MarginRight = 0  
                    With .TextRange.Characters  
                        .Font.Fill.ForeColor.RGB = RGB(255, 0, 0)  
                        .Text = arrElemNames(ii)  
                        .Font.Size = 5  
                    End With  
                End With  
                Set xlShp = Nothing  
            End If  
 
        Next  
        '---------------------os skali------------------------  
        Set xlShp = .Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, _  
                                              .Left, .Top + .Height * 0.87, _  
                                              .Width, 0.2)  
        '---------------------grupowanie ------------------------  
        Dim tblNames() As Variant, i As Integer  
              
        For Each xlShp In .Parent.Shapes  
            If Not Intersect(xlShp.TopLeftCell, .Cells) Is Nothing Then  
                ReDim Preserve tblNames(i)  
                tblNames(i) = xlShp.Name: i = i + 1  
            End If  
        Next  
        If i > 0 Then Set xlShp = .Parent.Shapes.Range(tblNames).Group  
    End With  
    With xlShp  
        .Name = xlLabelName  
    End With  
    Set xlShp = Nothing  
    WykresZLewej = vbNullString  
End Function  
 
a formuła którą należy wpisać do zakresu scalonych komórek może wyglądać następująco:  
 
gdzie zgodnie z arg. funkcji:   
 - kom.L4 - mininum skali  
 - kom.L3 - maksimum skali  
 - kom.O3 - przyjęta nroma  
 - "nazwa"&Wiersz(3:3) - unikatowa nazwa która  
    zostanie nadana dla całej grupy kształtów  
    składających się na ten "wykres"  
 - "Wykres 4" - nazwa wykresu na którego danych  
    będziemy pracować.  
 
 
 
Jak więc działa ta funkcja.  
 
    With Application.Caller.MergeArea  
        On Error Resume Next  
        .Parent.Shapes(xlLabelName).Delete  
        On Error GoTo 0  
 
xlLabelName to nazwa grupy kształtów składających się na "wykres". Jeżeli taka grupa istnieje to ją usuwamy.  
 
        With .Parent.ChartObjects(xlChrObjName).Chart.SeriesCollection(1)  
            '--------------Kwartyle danych------------  
            Q1 = Application.Quartile(.Values, 1)  
            Q2 = Application.Quartile(.Values, 2)  
            Q3 = Application.Quartile(.Values, 3)  
            '--------------min i max Serii------------  
            min = Application.min(.Values)  
            max = Application.max(.Values)  
        End With  
        arrElement = VBA.Array(min, max, Q1, Q2, Q3)  
        arrElemNames = VBA.Array("min", "max", "Q1", "Q2", "Q3")  
 
Stworzenie obiektu Excel.Chart funkcją Arkuszową spowoduje oczywiście błąd ale nie ma przeszkód aby zczytać w określonej serii  
jakiegoś wykresu wartości tej serii. Ja niepotrzebuję wszystkich wartości a jedyniewyliczam z nich to czego potrzebuję.  
Tablice arrElem* są mi potrzebne do strorzenia opsiu na osi - w pętli. (Te czerwone)  
 
        '---------------------linia główna-----------------  
        Dim xMin As Double: xMin = .Left + .Width * (min - dMin) / (dMax - dMin)  
        Dim xMax As Double: xMax = .Left + (.Width * (max - dMin) / (dMax - dMin)) - xMin  
        If xMin < .Left Then xMin = .Left  
        If xMax > .Left + .Width Then xMax = .Left + .Width  
        .Parent.Shapes.AddTextbox msoTextOrientationHorizontal, _   Shapes.AddTextbox Method
AddTextbox(Orientation, Left, Top, Width, Height, Anchor)
                                  xMin, .Top + .Height / 2, _  
                                  xMax, 1  
 
No i tu "cała magia" ;-)  
 - .Left + .Width (With Application.Caller.MergeArea) to cała szerokość miejsca jakie mamy na nasz "wykres"  
 - (??? - dMin) / (dMax - dMin) to miejsce (.Left) zmiennej ??? :-)  
 - Żaden element "wykresu" nie może wystawać (z Lewej-Górnej strony) poza obszar wyznaczony dla "wykresu"  
i "ot" cała filozofia :-)  
 
Na dobrą sprawę tyle :-) znając powyższe zasady analiza reszty kodu wstawiania elementów jest już dość łatwa.  
 
Na końcu  
 
        '---------------------grupowanie ------------------------  
        Dim tblNames() As Variant, i As Integer  
              
        For Each xlShp In .Parent.Shapes  
            If Not Intersect(xlShp.TopLeftCell, .Cells) Is Nothing Then  
                ReDim Preserve tblNames(i)  
                tblNames(i) = xlShp.Name: i = i + 1  
            End If  
        Next  
        If i > 0 Then Set xlShp = .Parent.Shapes.Range(tblNames).Group  
    End With  
    With xlShp  
        .Name = xlLabelName  
    End With  
 
Grupowanie stworzonych kształtów w zakresie Application.Caller.MergeArea i nadanie im wspólnej nazwy żeby je łatwo odnalazła  
funkcja przy odświeżaniu wartości.  
 
A teraz taka trochu inna możliwość takeij konstrukcji:  
 
Zaprezentowaną metodą  
można porównywać zestawy  
danych między sobą.  
Mamy 6 obserwacji: (y1-y6)  
kol:B:G.  
Tworzymy na tej podstawie  
6 wykresów. A do nich  
6 naszych "wykresów"  
podając: unikatowe  
nazwy dla grup kształtów,  
nazwy wykresów z których  
"czytamy" dane. I wspólne  
min, max i normę.  
Uzyskamy w ten sposób  
stałą skalę i normę dla  
każdego "wykresu" ale  
graficzne przedstawienie  
danych będzie indywidyalne  
każdego zestawy danych.  
 
Takie zestaw znajdziecie  
w załączniku :-)  
 
 
  przykład do pobrania
  chr01.zip