Własny wykres do porównywania zagregowanych danych.   strona główna:
A po co ten Excel ;-)
 
"Wykres" to to do końca nie będzie ale może sam fakt że "tak też można" ;-) kiedyś - komuś  
otworzy możliwość realizacji swoich wizji :-)  
 
Obrazek obok pokazuje zarówno dane jak i pożądany efekt. W dwóch słowach: mamy kolumnę  
liczb i chcielibyśmy zaprezentować na wykresie perc5%; medianę; perc95% w przedstawionej  
postaci. :-) To może nie "wygląda źle"… a gdyby całe zadanie opierało się na takiej prezentacji  
danych to przedstawiany sposób realizacji zadania byłby "przesadzony".. :-)  
Jednak to nie całość…  
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
Kolumn jest więcej ;-) i to jeszcze po 3 w grupie… 7 grupach :-D  
i marzyła by mi się jeszcze kreska łącząca znaczniki wszystkich A/B/C w poszczególnych Grupach - taki trend! :-)  
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
efekt mógłby wyglądać tak:  
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
no i mój stan wiedzy nt. wykresów w Excelu (nie czuję się w tym zakresie silny) niestety nie wystarcza do realizacji takiego zadania  
..no ale co??? Nie da się??? ;-)  
 
Da się!! :-) Wykres to przecież nic innego jak zestaw kresek.. jak określi się pozycję tych kresek można stworzyć wszystko :-)  
Wykres powstanie jako wynik Formuły Arkuszowej wpisanej do zakresu scalonych komórek tworzących obszar wykresu.  
To jednak zobaczycie w pliku.. ważniejsze jaka formuła arkuszowa stworzy taki obraz??  
 
Option Explicit  
Type dLL  
    dX As Double  
    dY As Double  
End Type  
 
Function MojWykres(sName As String, _  
                   obMin As Double, obMax As Double, _  
                   kor As Double, _  
                   rngColor As Excel.Range, _  
                   ParamArray vSeria() As Variant) As Boolean  
      
    If xlKoniec Then Exit Function  
    Dim xlShp As Excel.Shape  
    Dim ddTop As Double, ddHig As Double  
    Dim tblLinia() As dLL, iLine As Byte  
 
    Application.Volatile  
 
    With Application.Caller.MergeArea  
        On Error Resume Next  
        .Parent.Shapes(sName).Delete  
 
        Dim iSeria As Byte  
        For iSeria = 0 To UBound(vSeria())  
              
            '---------------główna kreska---------------  
            ddTop = ((.Height) / (obMax - obMin) * (obMax - vSeria(iSeria).Cells(3)))  
            ddHig = ((.Height) / (obMax - obMin) * (obMax - vSeria(iSeria).Cells(1)))  
            Set xlShp = .Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, _  
                                      (.Left + (.Width / (UBound(vSeria()) + 2)) * (1 + iSeria)) + kor, _  
                                      .Top + ddTop, _  
                                      0.01, ddHig - ddTop)  
            With xlShp  
                .Line.ForeColor.RGB = VBA.RGB(0, 0, 0)  
                .Fill.ForeColor.RGB = VBA.RGB(0, 0, 0)  
            End With  
             '---------------kreski poprzecznie min i max  
            Set xlShp = .Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, _  
                                      (.Left + (.Width / (UBound(vSeria()) + 2)) * (1 + iSeria)) - 5 + kor, _  
                                      .Top + ddTop, _  
                                      10, 0.01)  
            With xlShp  
                .Line.ForeColor.RGB = VBA.RGB(0, 0, 0)  
                .Fill.ForeColor.RGB = VBA.RGB(0, 0, 0)  
            End With  
            Set xlShp = .Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, _  
                                      (.Left + (.Width / (UBound(vSeria()) + 2)) * (1 + iSeria)) - 5 + kor, _  
                                      .Top + ddHig, _  
                                      10, 0.01)  
            With xlShp  
                .Line.ForeColor.RGB = VBA.RGB(0, 0, 0)  
                .Fill.ForeColor.RGB = VBA.RGB(0, 0, 0)  
            End With  
              
            '---------------znacznik----------------  
            ddTop = .Top + ((.Height) / (obMax - obMin) * (obMax - vSeria(iSeria).Cells(2)))  
            ddHig = (.Left + (.Width / (UBound(vSeria()) + 2)) * (1 + iSeria)) - 2.5 + kor  
              
            ReDim Preserve tblLinia(iLine)  
            tblLinia(iLine).dX = ddTop  
            tblLinia(iLine).dY = ddHig  
            iLine = iLine + 1  
              
            Set xlShp = .Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, _  
                                      ddHig, ddTop - 2.5, _  
                                      5, 5)  
            With xlShp  
                .Line.ForeColor.RGB = VBA.RGB(50, 50, 50)  
                .Fill.ForeColor.RGB = rngColor.Interior.Color  
            End With  
        Next  
 
        Dim ii As Byte  
        For ii = 0 To iLine - 1  
            With .Parent.Shapes.AddConnector(msoConnectorStraight, _  
                        tblLinia(ii).dY, _  
                        tblLinia(ii).dX, _  
                        tblLinia(ii + 1).dY, _  
                        tblLinia(ii + 1).dX)  
                .Line.Weight = 2  
                .Line.ForeColor.RGB = rngColor.Interior.Color  
            End With  
        Next  
   
 
        '-------Grupowanie-------  
        Dim tblNames() As Variant, iName As Integer  
        Dim xlLine As Excel.Line  
          
        For Each xlLine In .Parent.Lines  
            If Not Intersect(xlLine.TopLeftCell, .Cells) Is Nothing Then  
                ReDim Preserve tblNames(iName)  
                tblNames(iName) = xlLine.Name  
                iName = iName + 1  
            End If  
        Next  
   
        Dim xlTxb As Excel.TextBox  
        For Each xlTxb In .Parent.TextBoxes  
            If Not Intersect(xlTxb.TopLeftCell, .Cells) Is Nothing Then  
                ReDim Preserve tblNames(iName)  
                tblNames(iName) = xlTxb.Name  
                iName = iName + 1  
            End If  
        Next  
 
        If iName > 0 Then Set xlShp = .Parent.Shapes.Range(tblNames).Group  
          
        xlShp.Name = sName  
    End With  
 
    Set xlShp = Nothing  
     
End Function  
 
Formuła to: =MojWykres("Nazwa001";AB1;AD1;-5;AD24;B31:B33;E31:E33;H31:H33;K31:K33;N31:N33;Q31:Q33;T31:T33)  
 
Function MojWykres(sName As String, _  
                   obMin As Double, obMax As Double, _  
                   kor As Double, _  
                   rngColor As Excel.Range, _  
                   ParamArray vSeria() As Variant) As Boolean  
 
sName - nazwa która posłuży mi do "odświeżania" formuły. Po zmianie danych muszę usunąć poprzednie wykres i stworzyć nowy.  
Usuwam zgrupowany zestaw elementów nazwany właśnie nazwą z sName. Następnie tworzę nowy zestaw elementów i po ich  
zgrupowaniu nazywam je sName.
 
obMin i obMax - to liczby które określą granice obszaru przewidzianego na wykres.  
odwołania w formule prowadza do ->>  
po co mi te liczby… ano.. Obszar komórek scalonych jest pewnej wielkości określanej  
poprzez Top i Height ale gdzie ja mam umieścić np.: wartość 40??  
Przyjmuję zatem że moje Height komórek obszaru wykresu znajdują się pomiędzy -10 a 70. Teraz wiem gdzie jest moja wartość 40  
Zmiana wielkości obszaru będzie również odzwierciedlona na wykresie. Np.: Nasz wykres obrazuje linię pomiędzy perc5% a perc95%  
jeżeli obszar określimy "blisko" tych wartości to kreska będzie "na całym" obszarze (pionowym) wykresu. Jeżeli natomiast obszar  
określimy istotnie mniejszy od perc5% i istotnie większy od perc95% to kreska reprezentująca ten zakres będzie "w środku" obszaru  
wykresu.  
kor - na razie pominę.
 
rngColor - to komórka z której wypełnienia pobierany jest kolor dla znacznika mediany.  
ParamArray vSeria() - to zakresy danych dla np.: A  
w poszczególnych Grupach.
 
W formule powyżej są to obszary..  
 
 
 
 
W efekcie otrzymujemy…  
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
Fajnie :-) ale teraz jak dołożyć kolejną serię?? :-|  
Niby oczywiste ale mi chwilę z tym zeszło ;-) Formuła zwraca obraz wykresu.. Trzeba wpisać tę formułę w komórkę która stanowi  
obszar wykresu.. Następne serie musza być w tym samym obszarze wykresu.. No ale tu już mam jedną formułę :-|  
Co zrobić?? Wpisać w obszar wykresu więcej formuł! Jak?? :-) Proste.. Łącząc kolejne formuły przez & :-)  
=MojWykres("Nazwa001";AB1;AD1;-5;AD24;B31:B33;E31:E33;H31:H33;K31:K33;N31:N33;Q31:Q33;T31:T33)&
MojWykres("Nazwa002";AB1;AD1;0;AF24;C31:C33;F31:F33;I31:I33;L31:L33;O31:O33;R31:R33;U31:U33)&
MojWykres("Nazwa003";AB1;AD1;5;AH24;D31:D33;G31:G33;J31:J33;M31:M33;P31:P33;S31:S33;V31:V33)
 
 
 
i to działa?? Ano działa! :-)  
i po to jest właśnie ten arg. Kor.. Chodzi o przesunięcie różnicujące kolejne serie danych.. Inaczej by się nakładały. Jak by ktoś tak  
chciał to może w każdą serię wpisać 0. Mi jednak zależało na małym przesunięciu.  
 
 
Pozostaje jednak jeszcze skala..  
Realizuje to inna formuła wstawiona na lewo od obszaru wykresu.  
 
Function RysujSkale(sName As String, _  
                    obMin As Double, obMax As Double, _  
                    skMin As Double, skMax As Double, _  
                    skok As Double, _  
                    As Integer) As Boolean  
    Dim xlShp As Excel.Shape  
    Dim ddTop As Double  
    If xlKoniec Then Exit Function  
      
    Application.Volatile  
    With Application.Caller.MergeArea  
        On Error Resume Next  
        .Parent.Shapes(sName).Delete  
        On Error GoTo 0  
          
        Dim i As Double  
        For i = skMin To skMax Step skok  
          
            ddTop = ((.Height) / (obMax - obMin) * (obMax - i))  
            'skala  
            Set xlShp = .Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, _  
                                      (.Left + .Width / 2), .Top + ddTop, _  
                                      dł, 0.01)  
            'text box  
            Set xlShp = .Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, _  
                                      (.Left + .Width / 2) - 10, .Top + ddTop, _  
                                      20, 10)  
            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(0, 0, 0)  
                    .Text = i  
                    .Font.Size = 8  
                End With  
                .TextRange.ParagraphFormat.Alignment = msoAlignCenter  
            End With  
          
        Next  
          
                '-------Grupowanie-------  
        Dim tblNames() As Variant, iName As Integer  
        Dim xlTxb As Excel.TextBox  
        For Each xlTxb In .Parent.TextBoxes  
            If Not Intersect(xlTxb.TopLeftCell, .Cells) Is Nothing Then  
                ReDim Preserve tblNames(iName)  
                tblNames(iName) = xlTxb.Name  
                iName = iName + 1  
            End If  
        Next  
        If iName > 0 Then Set xlShp = .Parent.Shapes.Range(tblNames).Group  
        xlShp.ZOrder msoSendToBack  
        xlShp.Name = sName
 
 
    End With  
End Function  
 
i formuła: =RysujSkale("Skala001";AB1;AD1;AF1;AH1;AJ1;350)  
 
Function RysujSkale(sName As String, _  
                    obMin As Double, obMax As Double, _  
                    skMin As Double, skMax As Double, _  
                    skok As Double, _  
                    As Integer) As Boolean  
 
pierwsze 3 jak w poprzedniej.. ale tu oprócz obszaru trzeba jeszcze  
określić skalę (skMin i skMax) i jej krok (skok).  
dł - to długość linii siatki  
 
No i jest mój wykres :-)  
Kod sobie przeanalizują zainteresowani. W pętli serii wstawiamy elementy,   
kreski, textboxy, łączniki.. całość grupujemy i jest! ;-)  
 
 
 
Minus takiego rozwiązania… kopiowanie takiego wykresu to kopiowanie  
poszczególnych elementów składających się na ten wykres. A to może  
się nie udać zrobić idealnie poprzez zwykłe zaznaczenie obszaru i   
kliknięcie Kopiuj.   
Poradziłem sobie z tym tak:  
 
Sub Kopiuj()  
    Application.ScreenUpdating = False  
    xlKoniec = True  
    With ActiveSheet  
        .[wykres].Copy  
        .Pictures.Paste.Select  
        Selection.Cut  
    End With  
      
    With Application  
        .CutCopyMode = False  
        .ScreenUpdating = True  
    End With  
    xlKoniec = False  
End Sub  
 
Całość składa się z TextBoxów i Linii których pozycja jest wyliczana i razem tworzą wykres. Jednak gdyby któryś element został  
wstawiony poza obszar wykresu to nie będzie podlegał zgrupowaniu i stracimy nad nimi kontrolę - nie zniknie po odświeżeniu :-|  
A jak takich elementów będzie sporo… Można poradzić sobie z tym pilnując żeby każdy element trafił w obszar lub nie był tworzony  
ale można też usuwać niezgrupowane elementy tak…  
 
Sub Ostatecznosc()  
    ActiveSheet.TextBoxes.Delete   przykład do pobrania
    ActiveSheet.Lines.Delete   wykres02.zip
End Sub  
 
kiedy to się może zdarzyć? Np.: jeżeli obszar wykresu będzie mniejszy od wartości będących składowymi wykresów lub skali.  
Można to pilnować formułami w  zakresie: obszar/skala/krok ale to pozostawiam zainteresowanym :-)