Nieuw tabblad met grafieken per lijn

[wiba89]

Allen
is het mogelijk om (waarschijnlijk met een macro) per rij uit tabblad 1 een nieuw tabblad te maken waar grafieken weergegeven staan met de gegevens uit die rij? Zoja, hoe doe ik dit? Je vindt een excel-bestand in bijlage waar een voorbeeld in staat. hetzelfde moet ik dus bereiken, maar voor meer data.
Hopelijk is het duidelijk zo...Bekijk bijlage Helpmij.xlsx

 

[cow18]

Sub Wiba()
    Set c = Sheets("blad1").Range("A1").CurrentRegion    'je gegevens
    skol = "CKMOPQRST"    'alle kolommen voor je grafiek
    For i = 2 To c.Rows.Count
        Application.Goto c, 1
        ActiveSheet.Shapes.AddChart2(201, xlColumnClustered).Select
        With ActiveChart
            Do While .SeriesCollection.Count
                .SeriesCollection(1).Delete
            Loop
            For j = 1 To Len(skol)
                .SeriesCollection.NewSeries
                .FullSeriesCollection(j).Name = "=" & ActiveSheet.Name & "!$" & Mid(skol, j, 1) & "$1"
                .FullSeriesCollection(j).Values = "=" & ActiveSheet.Name & "!$" & Mid(skol, j, 1) & "$" & i
            Next
            .Legend.Position = xlRight
            .ChartTitle.Delete
            .Location Where:=xlLocationAsNewSheet
            On Error Resume Next
            ActiveSheet.Name = c.Cells(i, "A").Value & " " & c.Cells(i, "B").Value
        End With
    Next
End Sub

 

[VenA]

@cow18, Ik kan de FullSeriesCollection niet vinden. Oude of juist nieuw versie bekeken vanaf Xl-2010?

Met een iets andere code

Sub VenA()
  ar = Sheets("Blad1").Cells(1).CurrentRegion
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  For Each sh In Sheets
    If sh.Name <> "Blad1" Then sh.Delete
  Next sh
    
  For j = 2 To UBound(ar)
    Charts.Add
      With ActiveChart
        .ChartType = xlColumnClustered
        For jj = 1 To UBound(ar, 2)
          If jj = 3 Or jj = 11 Or jj = 13 Or jj > 15 Then
            t = t + 1
            .SeriesCollection.NewSeries
            .SeriesCollection(t).Name = ar(1, jj)
            .SeriesCollection(t).Values = ar(j, jj)
          End If
        Next jj
      End With
      t = 0
      ActiveSheet.Name = ar(j, 1) & ar(j, 2)
  Next j
End Sub

 

[cow18]

@VenA,
ik gebruik office 2013 en had via de macro-recorder ea opgenomen en daarna een beetje gefatsoeneerd.
Ik kijk morgen even naar die fullseriescollection, maar jouw versie mag er ook zijn

 

[snb]

zou dit niet ook gaan ?

with Charts.Add
    .ChartType = xlColumnClustered
    For jj = 1 To UBound(ar, 2)
      If jj = 3 Or jj = 11 Or jj = 13 Or jj > 15 Then
        with .SeriesCollection.Add
         .Name = ar(1, jj)
         .Values = ar(j, jj)
        End If
     Next
  End With

 

[wiba89]

Super! Bedankt alvast allemaal!

Als ik nu nog grafieken wil aanpassen (zonder dat ik dat in ieder tabblad afzonderlijk wil doen), hoe ga ik daar dan mee aan de slag?

 

[cow18]

zet de macro-recorder aan en verander 1 grafiek
zet de macro-recorder terug af en kijk wat hij allemaal opgenomen heeft.
Gooi de meeste rommel eruit en wat er overblijft, dat kopieer je net voor die "End With"

Als je niet weet wat "rommel" is, zet hier dan een keer neer wat die macro-recorder er van gemaakt heeft.

 

[VenA]

Ik blijf het maar lastige objecten vinden die grafieken. Een macro-opname geeft vaak de juiste richting en kan je opschonen maar is moeilijker bij dit object. En dan zal je de help moeten raadplegen. En dat kost tijd en moeite. Het koste mij 'maar' een uurtje op de titel in de grafieken te krijgen

@cow18,
FullSeriesCollection is inderdaad pas vanaf XL-2013 beschikbaar. En natuurlijk niet backwards compatible.

@snb,
Los van de missing end with, werkt with .SeriesCollection.Add niet (is een andere methode)
Zo gaat het wel goed en scheelt inderdaad wat regels.

  For jj = 1 To UBound(ar, 2)
   If jj = 3 Or jj = 11 Or jj = 13 Or jj > 15 Then
      With .SeriesCollection.NewSeries
       .Name = ar(1, jj)
       .Values = ar(j, jj)
      End With
    End If
  Next jj

Voor de volledigheid

Sub VenA()
  ar = Sheets("Blad1").Cells(1).CurrentRegion
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  For Each sh In Sheets
    If sh.Name <> "Blad1" Then sh.Delete
  Next sh
    
  For j = 2 To UBound(ar)
    With Charts.Add
      .ChartType = xlColumnClustered
      .HasTitle = True
      .ChartTitle.Text = ar(j, 1) & ar(j, 2)
      For jj = 1 To UBound(ar, 2)
        If jj = 3 Or jj = 11 Or jj = 13 Or jj > 15 Then
          With .SeriesCollection.NewSeries
            .Name = ar(1, jj)
            .Values = ar(j, jj)
          End With
        End If
      Next jj
    End With
    ActiveSheet.Name = ar(j, 1) & ar(j, 2)
  Next j
End Sub