• 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.

plotarea

Status
Niet open voor verdere reacties.
S

Symphysodon

Gebruiker
Lid geworden
14 dec 2012
Berichten
468
Beste Forummers,

Ik heb een stuk code om grafieken passend te maken op een pagina met verschillende opties. Dit gaat goed met het vullen van een pagina maar niet met het plotarea. Om een reden die ik niet snap looped de setting van de plotarea niet mee. Elke grafiek moet even groot zijn en dat zijn ze niet. Dit is de code die ik tot nu heb:
Code: 
Sub eengrfperpagina()
Dim W As Long, H As Long
Dim i, j As Long
Application.ScreenUpdating = False
Sheets("Graphics").ChartObjects("meetpunt 1").Activate
'1 grafiek op 1 pagina
ActiveSheet.PageSetup.Orientation = xlLandscape

For i = 1 To ActiveSheet.ChartObjects.Count
W = 672
H = 465
    
    With ActiveSheet.ChartObjects(i)
        .Width = W
        .Height = H
        .Left = 0
        .Top = (i - 1) * H
        ActiveSheet.ChartObjects("meetpunt " & i).Activate
        With ActiveChart
            .PlotArea.Width = W - 120
            .Axes(xlValue).AxisTitle.Font.Size = 11
            .ChartTitle.Font.Size = 9
        End With

        For j = 2 To 8
            With ActiveChart.FullSeriesCollection(j).DataLabels.Format.TextFrame2.TextRange.Font
                .Size = 9
            End With
        Next
   End With
Next i
Sheets("Graphics").Activate
Application.ScreenUpdating = True
End Sub

mvg
Marco
 
Handig testen zo zonder bestand.
Sinds 2012 op dit forum en dan nog steeds 'Activate' gebruiken in VBA ???
 
Het stukje code is een onderdeel van een Userform en dat maakt het allemaal veel onoverzichtelijker, ook omdat het nog niet af is. Ik heb geprobeerd om apart een bestand te maken maar daar doet het programma het wel. Waarschijnlijk gaat het om de datalabels die roet in het eten gooien. Als ik het stukje code met: plotarea weg laat dan worden de datalabels overschreven door het plotarea. In de bijlage het voorbeeld wat ik gemaakt heb.

Natuurlijk neem ik je advies altijd ter harte, je bent een goeie programmeur. Het probleem is alleen dat het vaak niet werkt en als ik dat dan aangeef dan antwoord je gewoon niet. Ik heb geen idee waarom je dat doet, maar ik moet wel verder en als dat dan met Activate moet dan is dat maar zo.

Als je geen Activate en Select mag gebruiken dan geldt dat dan toch veel meer voor lussen zoals For ..Next?

Een ander probleem met het programma is dat de breedte en de hoogte (in geval van 1 grafiek per pagina) van de grafiek, paginavulled moet zijn. Ik heb nu al een paar keer de de W en H waarden aangepast maar iedere keer als ik het programma afsluit of het open mbv VNC vanaf een andere computer dan zijn de maten weer anders (zie ook voorbeeld). Ik heb geprobeerd dit op te lossen door de kolombreedte in WorkbookOpen vast te leggen (zie voorbeeld) maar dat werkt niet.
 

Bijlagen

Code: 
Sub M_snb()
  On Error Resume Next
  
  For Each it In Blad2.Shapes
     it.Placement = 3
     Blad2.HPageBreaks.Add it.TopLeftCell
  Next
End Sub

Analyseer de suggestie voordat je hem gebruikt.
 
ik weet niet waar je naar toe wil, dus heb een beetje van alles toegevoegd.
 

Bijlagen

Volgens mij is dit afdoende:
Code: 
Sub AlleGrafiekenInstellen()
    Dim cht As ChartObject
    Application.PrintCommunication = False
    For Each cht In ActiveSheet.ChartObjects
        With cht.Chart.PageSetup
            .Orientation = xlLandscape
        End With
    Next
    Application.PrintCommunication = True
End Sub

Sub AlleGrafiekenAfdrukken()
    Dim cht As ChartObject
    AlleGrafiekenInstellen
    For Each cht In ActiveSheet.ChartObjects
        cht.Chart.PrintOut preview:=True
    Next
End Sub
 
Ik heb het gehele programma wat ik tot nu toe af heb uitgekleed tot alleen het probleem wat ik schets (zie bijlage). Dan wordt het probleem hopelijk wat duidelijker.
Het doel van dit stukje programma is dat je de mogelijkheid hebt om 1 grafiek per pagina op het scherm te zien, twee grafieken per pagina of vijf grafieken per pagina. De keuze heb ik verwerkt in een Userform maar heb dat in dit voorbeeld weggelaten. In dit geval heb ik dus drie Sub's.

Het eerste probleem is dat het soms niet klopt, dan is de grafiek bijvoorbeeld net iets te breed voor 1 pagina. Het gekke is wel dat dat nu niet meer voorkomt????

Het tweede probleem is dat het plotarea, zeg maar het binnenste kader van de grafiek niet bij alle grafieken even groot zijn en dat daardoor de datalabels aan de rechterkant doorkruist worden door het plotarea kader. Het probleem is meteen zichtbaar als je schakelt tussen de verschillende sub's.

Ik heb de eerste Activate verwijderd en het object geset, dit is me niet gelukt met de activechart? De Sub's werken daarom alleen in de Graphics sheet.

Verder lukt het niet (meer) om de grafiek een naam te geven. Ik deed dat altijd door met Ctr ingedrukt een grafiek te selecteren en dan in het veld links bovenaan een nieuwe naam te typen.
 

Bijlagen

Ik heb de computer maar eens volledig uitgezet en weer aan. Dit heeft geholpen voor het passend maken voor de grafieken, de grafieken passen precies op een pagina en sluiten door het gebruik van de mod formule netjes aan. Ook het geven van een naam zoals beschreven werkt weer.

Het is ook gelukt om geen Activate te gebruiken op het zichtbaar maken van het tabblad na, als het programma beëindigd is.

Wat overblijft is de grote van het plotarea. Ik bedoel dan niet de printpreview maar de grafieken die je op de sheet Graphics ziet. Daar zijn de plotarea's per grafiek verschillend van grootte.

Code: 
Sub eengrfperpagina()
Dim W As Long, H As Long
Dim i, j As Long
Dim ChtObj As ChartObject

Application.ScreenUpdating = False
Set s = Sheets("Graphics").ChartObjects("meetpunt 1")
'1 grafiek op 1 pagina
Sheets("Graphics").PageSetup.Orientation = xlLandscape
For Each ChtObj In Sheets("Graphics").ChartObjects
    For i = 1 To Sheets("Graphics").ChartObjects.Count
    W = 672
    H = 465
        
        With Sheets("Graphics").ChartObjects(i)
            .Width = W
            .Height = H
            .Left = 0
            .Top = (i - 1) * H
            
            With ChtObj.Chart
                .PlotArea.Width = W - 120
                .Axes(xlValue).AxisTitle.Font.Size = 11
                .ChartTitle.Font.Size = 9
            End With
    
            For j = 2 To 8
                With ChtObj.Chart.FullSeriesCollection(j).DataLabels.Format.TextFrame2.TextRange.Font
                    .Size = 9
                End With
            Next
       End With
    Next i
Next
Sheets("Graphics").Activate
Application.ScreenUpdating = True
End Sub
Sub tweegrfnperpagina()
Dim W As Long, H As Long
Dim ChtObj As ChartObject
Dim i, j As Long

Set s = Sheets("Graphics").ChartObjects("meetpunt 1")
'2 grafieken op 1 pagina
Sheets("Graphics").PageSetup.Orientation = xlPortrait
W = 432
H = 360
For Each ChtObj In Sheets("Graphics").ChartObjects
    For i = 1 To Sheets("Graphics").ChartObjects.Count
          
            With Sheets("Graphics").ChartObjects(i)
                .Width = W
                .Height = H
                .Left = 0
                .Top = (i - 1) * H
                For j = 2 To 8
                    With ChtObj.Chart.FullSeriesCollection(j).DataLabels.Format.TextFrame2.TextRange.Font
                        .Size = 9
                    End With
                Next
                With ChtObj.Chart
                    .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 i, j As Long
Dim ChtObj As ChartObject

Application.ScreenUpdating = False
Set s = Sheets("Graphics").ChartObjects("meetpunt 1")
'5 grafieken op 1 pagina staand
Sheets("Graphics").PageSetup.Orientation = xlPortrait

W = 216
H = 240
For Each ChtObj In Sheets("Graphics").ChartObjects
    For i = 1 To Sheets("Graphics").ChartObjects.Count
        With Sheets("Graphics").ChartObjects(i)
            .Width = W
            .Height = H
            .Left = ((i - 1) Mod 2) * W
            .Top = Int((i - 1) / 2) * H
            
            For j = 2 To 8
                With ChtObj.Chart.FullSeriesCollection(j).DataLabels.Format.TextFrame2.TextRange.Font
                    .Size = 6
                End With
            Next
                With ChtObj.Chart
                    .Axes(xlValue).AxisTitle.Font.Size = 9
                    .ChartTitle.Font.Size = 8
                End With
        End With
    Next i
Next
Application.ScreenUpdating = True
End Sub
 
Het is gelukt. :thumb: Ik heb de grafieken verwijderd en opnieuw opgebouwd en nu blijven de plotarea's allemaal even groot.

Ik zal nog eens goed die Hpagebreak bestuderen, heb het nog niet helemaal door.

Bedankt allemaal voor het meedenken.

mvg
Marco
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan