• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

afronden datalabel

Status
Niet open voor verdere reacties.
dank je !

Ivm. het afronden, eigenlijk zou je bij het afronden van je getal ook je sigma in rekening moeten brengen, dus hierbij
Code: 
Function AfrondenSD(getal, sd)
   sp = Split(Format(sd, "0.0e+00"), "e")
   AfrondenSD = Application.WorksheetFunction.Round(getal, -sp(1))
End Function

en dan wordt je label
Code: 
 For ipts = 1 To .Points.Count                 'alle punten aflopen
                     [COLOR="#FF0000"].Points(ipts).DataLabel.Formula = IIf(ipts = .Points.Count, "gem " & IIf(i = 5, "", IIf(i > 5, "+", "") & -5 + i & "s ") & "= " & AfrondenSD(y0, sd), "")  'alleen voor laatste punt label corrigeren, de rest is leeg[/COLOR]
                  Next
 
Laatst bewerkt:
usVerwerking werkt nu.
Code: 
            If usVerwerking.OptionButton1 = True Then
                Sheets("Admin").Visible = True
                g = Sheets("Admin").Cells(i + 7, 3).Value
                sd = Sheets("Admin").Cells(i + 7, 4).Value
            End If
Met het testen stuit ik op het probleem dat bij een bepaald aantal metingen (~>500) de x-as 'vol loopt', ik krijg dan een foutmelding op .values=a
Code: 
               With .FullSeriesCollection(i)                    'voor die bepaalde reeks
                  .Values = a                                   'string toevoegen
                  .Name = "gem " & IIf(i >= 5, "+", "") & -5 + i & "s"
                  .ApplyDataLabels                              'labels activieren
                  For ipts = 1 To .Points.Count                 'alle punten aflopen
                     .Points(ipts).DataLabel.Formula = IIf(ipts = .Points.Count, "gem " & IIf(i >= 5, "+", "") & -5 + i & "s = " & Afronden(y0), "")   'alleen voor laatste punt label corrigeren, de rest is leeg
                  Next
               End With

Er is nog een ander probleem dat wanneer ik de user form usVerwerking een aantal keer gebruikt heb, ik bij elke handeling de melding krijg: Onvoldoende geheugen. Pas als ik dan de computer weer opnieuw opstart gaat het weer een tijdje goed.
 
Laatst bewerkt:
aan de usVerwerking heb ik niet gekomen.

De verwerking is nu lichtjes anders, dus zou het vollopen van de x-as niet mogen gebeuren.
Eigenlijk zou je dat met gedefinieerde bereiken kunnen doen, maar dat is éénmalig nogal arbeidsintensief en foutgevoelig, dus gemakkelijkheidshalve is dat opgelost in VBA.
Je zou eigenlijk dus ook meerdere blokken van gegevens kunnen hebben met daartussen dan een pauze. (bv. meetpunt 2)

Die geheugenproblemen heb ik ook niet gehad .
 

Bijlagen

Laatst bewerkt:
Het lijkt te werken alleen staan er nu formules in de datasheet ipv ruwe data
Code: 
=24.78422+ASELECT()*(1+(REST(RIJ(),100)=0))
Als ik nu data uit meetpunt 2 verwijder veranderen de getallen van meetpunt 1
 
klopt, vroeger stonden daar een 50-tal regels met data in.
Om je probleem van >500 regels na te bootsen heb ik daar een formule ingezet voor reeks 1, 3 en 5.
Verwijder alles en zet de originele gegevens (of andere) terug in je tabel van data.
 

Bijlagen

Laatst bewerkt:
ik heb de oude gegevens in #25 toegevoegd.
 
ik heb nog een aantal regels als commentaar gezet, eigenschappen die een keer je die goed gezet hebt, niet meer moeten aangepast worden.

leek toch niet zo goed te werken, dus de oude terug
 

Bijlagen

Laatst bewerkt:
Als ik het goed lees heb je de horizontale lijnen nu op basis van 2 punten zoals ik het eerst had min of meer. Nu wil ik de kleuren van de lijnen in vba vastleggen maar heb nog niet helemaal door hoe ik dat kan doen, of moet ik daar dan een aparte lus voor aanmaken.
De 3s moet rood zijn, 1s en 2s gestippeld groen en de gemiddelde lijn zwart.
De thicklabel.orientatie van de y-as het liefst horizontaal.

In de bijlage de laatste versie met een werkend usVerwerking.
 

Bijlagen

Laatst bewerkt:
Zoiets:
Code: 
                y0 = g + (-5 + i) * sd   
With .FullSeriesCollection(i)                    'voor die bepaalde reeks

                  .XValues = Array(1, UBound(Ywaarden) + 1)     'x-waarden voor de 2 punten
                  .Values = Array(y0, y0)                       'y-waarden voor die 2 punten
                  .ApplyDataLabels                              'labels activieren
                  
                  For ipts = 1 To .Points.Count                 'alle punten aflopen
                     v = ...
                     Select Case v
                        Case 0: .Points(ipts).Format.Line.ForeColor.RGB = RGB(0, 0, 0)
                        Case 1: .Points(ipts).Format.Line.ForeColor.RGB = RGB(0, 0, 255)
                        Case Else: .Points(ipts).Format.Fill.ForeColor.RGB = RGB(255, 0, 0)   'rest = rood
                     End Select
                     .Points(ipts).DataLabel.Formula = IIf(ipts = .Points.Count, "gem " & IIf(i = 5, "", IIf(i >= 5, "+", "") & -5 + i & "s ") & "= " & AfrondenSD(y0, sd), "")   'alleen voor laatste punt label corrigeren, de rest is leeg
                  Next
               End With
 
Laatst bewerkt:
die select case moet enkele lijntjes hoger staan, heb ik zo de eerste indruk.
Zo meteen antwoord.
 
zie bijlage, uitvoeren van de macro duurt bij mij 0.6 sec, waarvan 0.55 sec enkel en alleen om de labels aan de rechterkant te zetten.
Frustrerend traag !
Je zou natuurlijk ook de 1e Y-as zo kunnen inrichten dat, die netjes bij gem-4*sd begint en dan telkens 1 sd oploopt. Dan heb je die labels niet nodig.

Misschien moet je nu zelf nog wat met de kleuren spelen.
standaard groen = RGB(0,255,0), maar je zal wel een nuance willen ... .

Inderdaad, er is teruggekeerd naar je oude insteek met 2 punten per serie voor de 7 horizontale lijnen (ivm. je geheugenproblemen)
 

Bijlagen

Laatst bewerkt:
Ik zie je berichtje nu pas. Zelf had ik dit nog bedacht voor die lijnen
Code: 
               y0 = g + (-5 + i) * sd                           'Y-waarde van een bepaalde horizontale reeks
               With .FullSeriesCollection(i)                    'voor die bepaalde reeks
   '.ChartType = xlXYScatterSmoothNoMarkers 'horizontale lijnen zijn spreidingsgrafieken
                  .XValues = Array(1, UBound(Ywaarden) + 1)     'x-waarden voor de 2 punten
                  .Values = Array(y0, y0)                       'y-waarden voor die 2 punten
                  .ApplyDataLabels                              'labels activieren
                  For ipts = 1 To .Points.Count                 'alle punten aflopen
                     
                     Select Case y0
                        Case g - 2 * sd, g + sd, g - sd, g + 2 * sd
                            .Points(ipts).Format.Line.ForeColor.RGB = RGB(0, 0, 255)
                        Case g: .Points(ipts).Format.Line.ForeColor.RGB = RGB(0, 0, 0)
                        Case Else: .Points(ipts).Format.Line.ForeColor.RGB = RGB(255, 0, 0)
                     End Select
                     .Points(ipts).DataLabel.Formula = IIf(ipts = .Points.Count, "gem " & IIf(i = 5, "", IIf(i >= 5, "+", "") & -5 + i & "s ") & "= " & AfrondenSD(y0, sd), "")   'alleen voor laatste punt label corrigeren, de rest is leeg
                  Next
               End With
         End Select
De code van jou is netter, maar ik ben al blij met iets werkends.

Het genereren van de labels is inderdaad tergend sloom maar ze zijn nodig omdat de horizontale lijnen ook berekend moeten kunnen worden op basis van een consensus gemiddelde en sd.

Krijg jij als je usVerwerking form gebruikt ook de melding: onvoldoende geheugen
Ik begrijp het niet: ik heb de snelste computer van de zaak
 
Laatst bewerkt:
Hulpkolommen verwijderd, naamverwijzingen aangepast (en opgeschoond) en programma daarop aangepast.

Kleuren bijgewerkt --> poging tot
Om de rode uitbijter zat een groen rand, geprobeerd te verwijderen met
Code: 
                  For ipts = 1 To .Points.Count                 'alle punten aflopen en kleuren ngl. afwijking sd
                     v = Application.Min(Abs(Fix((Ywaarden(ipts - 1) - g) / sd)), 4)
                     Select Case v
                        Case 0 To 2:                            '.Points(ipts).Format.Fill.ForeColor.RGB = RGB(0, 255, 0)   '0 en 1 = groen
                        Case Else
                            .Points(ipts).Format.Fill.ForeColor.RGB = RGB(255, 0, 0)   'rest = rood
                            .Point(ipts).ActiveChart.PlotArea.Format.Line.Visible = msoFalse 'werkt niet!!
                     End Select
                  Next
Krijg foutmelding

Na testen waarde uitbijters schiet labels x-as naar het midden bij negatieve uitbijter. (zie bijlage).
 

Bijlagen

die uitbijters, inhoud en rand zijn nu met markerforegroundcolor en markerbackgroundcolor (een andere property) !!

Tikfout in jouw lijn "werkt niet", daar staat er "Point" ipv "Points" = pijnlijke, moeilijk op te merken fout

X-as die plots van plaats veranderde, was doordat een regel als opmerking (er stond een enkel aanhalingsteken ervoor) stond en die is nu weggehaald.
Code: 
        .CrossesAt = .MinimumScale                             'Stond als opmerking, dus deed zijn werk niet meer <----------------------------------GEWIJZIGD-----------------
 

Bijlagen

Helemaal duidelijk.

Volgende probleem waar ik niet uit kom is de presentatie van de grafieken. Ik heb daar een userform voor gemaakt met voor elke presentatie een keuze. het probleem is dat de grafieken niet altijd allemaal even groot zijn en dat de labels niet altijd mooi rechts van het kader komen te staan bij bijvoorbeeld 5 grafieken op 1 pagina. Misschien kloppen de formules niet die ik gebruikt heb. Het is wel zo dat de grafieken hierdoor mooi aansluiten.
Dit zijn de codes voor de verschillende presentaties
Code: 
Sub eengrfperpagina()
   Dim W As Long, H As Long
   Dim i, j    As Long
   Dim ChtObj  As ChartObject
   Application.ScreenUpdating = False

   '1 grafiek op 1 pagina
   Sheets("Grafieken").PageSetup.Orientation = xlLandscape
   For Each ChtObj In Sheets("Grafieken").ChartObjects
      For i = 1 To Sheets("Grafieken").ChartObjects.Count
         W = 672
         H = 465
         With Sheets("Grafieken").ChartObjects(i)
            .Width = W
            .Height = H
            .Left = 0
            .Top = (i - 1) * H
            With ChtObj.Chart
               .Axes(xlValue).AxisTitle.Font.Size = 11
               .ChartTitle.Font.Size = 9
               For j = 2 To 8
                  With .FullSeriesCollection(j).DataLabels.Format.TextFrame2.TextRange.Font
                     .Size = 9
                  End With
               Next

            End With
         End With
      Next i
   Next
   Application.ScreenUpdating = True
End Sub
Sub tweegrfnperpagina()
   Dim W As Long, H As Long
   Dim ChtObj  As ChartObject
   Dim i, j    As Long
   Application.ScreenUpdating = False

   '2 grafieken op 1 pagina
   Sheets("Grafieken").PageSetup.Orientation = xlPortrait
   For Each ChtObj In Sheets("Grafieken").ChartObjects
      For i = 1 To Sheets("Grafieken").ChartObjects.Count
         W = 432
         H = 360
         With Sheets("Grafieken").ChartObjects(i)
            .Width = W
            .Height = H
            .Left = 0
            .Top = (i - 1) * H
            With ChtObj.Chart
               For j = 2 To 8
                  With .FullSeriesCollection(j).DataLabels.Format.TextFrame2.TextRange.Font
                     .Size = 9
                  End With
               Next
               .Axes(xlValue).AxisTitle.Font.Size = 11
               .ChartTitle.Font.Size = 9
            End With
         End With
      Next i

   Next

   Application.ScreenUpdating = True
End Sub

Sub vijfgrfnperpagina()
   Dim W As Long, H As Long
   Dim ChtObj  As ChartObject
   Dim i, j    As Long
   Application.ScreenUpdating = False

   '5 grafieken op 1 pagina staand
   Sheets("Grafieken").PageSetup.Orientation = xlPortrait
   For Each ChtObj In Sheets("Grafieken").ChartObjects
      For i = 1 To Sheets("Grafieken").ChartObjects.Count
         W = 216
         H = 240
         With Sheets("Grafieken").ChartObjects(i)
            .Width = W
            .Height = H
            .Left = ((i - 1) Mod 2) * W
            .Top = Int((i - 1) / 2) * H
            With ChtObj.Chart
               For j = 2 To 8
                  With .FullSeriesCollection(j).DataLabels.Format.TextFrame2.TextRange.Font
                     .Size = 6
                  End With
               Next
               .Axes(xlValue).AxisTitle.Font.Size = 9
               .ChartTitle.Font.Size = 8
            End With
         End With
      Next i
   Next
   Application.ScreenUpdating = True
End Sub
Sub vijfgrfnperpaginaonderelkaar()
   Dim W As Long, H As Long
   Dim ChtObj  As ChartObject
   Dim i, j    As Long
   Application.ScreenUpdating = False

   '5 grafieken op 1 pagina
   Sheets("Grafieken").PageSetup.Orientation = xlPortrait

   For Each ChtObj In Sheets("Grafieken").ChartObjects
      For i = 1 To Sheets("Grafieken").ChartObjects.Count
         W = 432
         H = 142.5
         With Sheets("Grafieken").ChartObjects(i)
            .Width = W
            .Height = H
            .Left = 0
            .Top = Int((i - 1)) * H
            With ChtObj.Chart
               For j = 2 To 8
                  With .FullSeriesCollection(j).DataLabels.Format.TextFrame2.TextRange.Font
                     .Size = 6
                  End With
               Next
               .Axes(xlValue).AxisTitle.Font.Size = 7
               .ChartTitle.Font.Size = 7


            End With
         End With
      Next i
   Next
   Application.ScreenUpdating = True
End Sub

In de bijlage het nieuwe bestand.
 

Bijlagen

als ik het goed begrijp, dan zouden de grafieken altijd netjes even groot moeten zijn.
In een grafiek zelf kan je de linkerkant en wijdte van de grafiek en van de plotarea bepalen.
Nu verknoeien de labels van de Y-as die wijdte en daar bestaat volgens mijn weten geen oplossing voor.

Workaround = geen labels voor die Y-as, maar we bouwen ze na met een 9e reeks, die gewoon op gegeven 1 staat met intervallen volgens wat de grafiek er zelf van bakt.

Dus ik heb wat zitten knoeien met van alles, dus bepaalde onderdelen zijn veranderd in grootte
in grote lijnen zou je het hiermee moeten doen.
- de macro "Alles Even Groot"
- een 9e reeks in "grafiek aanpassen"

Ik gok dat je nu met de titel van de Y-as wat layout-problemen zal hebben. Ik veronderstel dat je dat wel zelf kan oplossen door bv. met de ".plotarea.left" te spelen of door die titel te verslepen.
 

Bijlagen

Bedankt het lijkt redelijk goed te werken. De titel van de grafiek blijft alleen niet in het midden en wat me nu opvalt is de lettergrootte aangepast moet kunnen worden van de X-as labels. Ik krijg het alleen niet voor elkaar omdat het object niet herkent wordt terwijl met de recoder lukt dat wel.
Code: 
Sub eengrfperpagina()
   Dim W As Long, H As Long
   Dim i, j    As Long
   Dim ChtObj  As ChartObject
   Application.ScreenUpdating = False

   '1 grafiek op 1 pagina
   Sheets("Grafieken").PageSetup.Orientation = xlLandscape
   For Each ChtObj In Sheets("Grafieken").ChartObjects
      For i = 1 To Sheets("Grafieken").ChartObjects.Count

         H = 465
         With Sheets("Grafieken").ChartObjects(i)
            .Width = 672
            .Height = H
            .Left = 0
            .Chart.PlotArea.Left = 30                              'linkerkant van de plotarea (zonder de labels is dat nu de Y-as)
            .Chart.Axes(xlValue).TickLabelPosition = xlNone        'geen labels tonen voor de Y-as, wordt straks door de 9e reeks ondervangen
            .Chart.PlotArea.Width = 572                            'wijdte van de plotarea (komt overeen met de niet gebruikte 2e Y-as)
            .Chart.FullSeriesCollection(9).DataLabels.Position = xlLabelPositionLeft   'labels van de 9e reeks links van de punten
            .Top = (i - 1) * H
            
            
            With ChtObj.Chart
               .Axes(xlValue).AxisTitle.Font.Size = 9
               .ChartTitle.Font.Size = 8
    With .Axes(xlCategory, xlPrimary).DataLabels.Format.TextFrame2.TextRange.Font '<-----Aanpassen lettergrootte labels x-as
        .BaselineOffset = 0
        .Size = 9
    End With
               For j = 2 To 9
                  With .FullSeriesCollection(j).DataLabels.Format.TextFrame2.TextRange.Font
                     .Size = 9
                  End With
               Next

            End With
         End With
      Next i
   Next
   Application.ScreenUpdating = True
End Sub

Ik heb de aanpassingen in de keuzeprogramma's: "Weergave_grfn" toegepast.

De formules in de data sheet (#25) blijven terug komen op het moment je er een nieuwe datum onderzet? --> opgelost (alle data verwijderd, ipv een deel, en cellen leeg gemaakt)
 

Bijlagen

Laatst bewerkt:
aanpassing in "eengrfperpagina"
blijkbaar maakte je 2 lussen om door je grafieken te wandelen, een beetje luxe-consumptie.
Dan moet je natuurlijk opletten voor welke je kiest en bijgevolg hoe je het binnen de lus noemt.
Bij die "ChtObj.Chart" volstaat de ".Chart" binnen die With ... End With, die ChtObj van de 1e lus had ik eruit gewipt.
Tenzij jij de andere lus liever zag, dan moet je al de rest logisch aanpassen.

En dan het geknoei met stukjes opnemen met de macro-recorder, dat blijft een leuk hulpding met beperkingen.
Ik heb gegoogled op "vba labels x axis" en dan zie je dat je met ".TickLabels" moet werken.
Dat is iets minder spectaculair dan ".DataLabels.Format.TextFrame2.TextRange" maar doet wel zijn werk.

Verder begrijp ik eigenlijk die opties niet voor 1 of meer grafieken.
Ik dacht dat je alle grafieken 1 keer juist kon zetten en daarna een keuze kon maken uit de gewenste.
Ik heb het niet in de details bestudeerd, maar door enkel bepaalde grafieken zichtbaar te houden kan je alles afdrukken zoals gewenst.
 

Bijlagen

Dank je wel, ook voor de extra uitleg. :)

De vraag kwam bij mij of er ook meerdere grafieken op 1 pagina geprint konden worden. Dat is de reden waarom ik die opties gemaakt hebt.
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan