33 grafieken in één keer maken vanuit een tabel ipv 33 kopieren

[dek8]

Hallo!

Ik heb bijgaande tabel met uitkomsten van data crunch sessie. Die tabel wil ik vertalen naar grafieken (en daarna naar powerpoint).

Dat kan rij voor rij, maar dat moét handiger kunnen. Ik vermoed dat een macro uitkomst bied, daar ben ik (nog) niet bekend mee. Als het ook zonder kan, is dat voor mij handiger, maar elke hulp is welkom!

Bedankt!

 

[AHulpje]

Hier al eens naar gekeken?
https://www.helpmij.nl/forum/showthread.php/965626-Draaitabel-invoegen

 

[dek8]

Deze had ik nog niet gezien, maar kan ik inderdaad verder mee, top, bedankt!

 

[dek8]

Toch nog even een vraag. De Macro werkt, ik heb hem zelfs enigszins aangepast, alleen wil ik graag de Gegevenslabels toevoegen aan de grafiek (het % moet boven de betreffende bar komen). Weet iemand welk stukje code daarbij hoort?




Option Explicit

Sub MaakGrafieken()
Dim i As Integer
For i = 2 To 34
MaakGrafiek i
Next
End Sub

Function MaakGrafiek(c)
ActiveSheet.Shapes.AddChart2(240, xlColumnClustered).Select
ActiveChart.SetSourceData Source:=Union(Columns(1), Columns(c))
ActiveChart.SetSourceData Source:=Union(ActiveSheet.Columns(1), ActiveSheet.Columns(c))

With ActiveChart.Parent
.Top = 150
.Left = (c - 2) * 410
.Width = 400
.Height = 250
End With
End Function

 

[AHulpje]

Om je op weg te helpen, zie bijlage.

 

[snb]

Je hebt alleen maar je bestaande grafiek nodig en een kleine macro:
Test met F8 in de VBEditor.

Sub M_snb()
  With Sheet1.ChartObjects(1).Chart
     .HasTitle = True
     For j = 2 To 34
        .SetSourceData Range("$B$1:$I1," & sheet1.Cells(j, 2).Resize(, 8).Address)
        .ChartTitle.Text = sheet1.Cells(j, 1)
        stop
     Next
  End With
End Sub

 

[dek8]

Bedankt allemaal!!

 

[snb]

Om het af te maken:
Deze code is voldoende voor een PP-presentatie met 33 grafieken.

Sub M_snb()
  Set pp = CreateObject("Powerpoint.application").presentations.Add
 
  With Sheet1.ChartObjects(1).Chart
    .HasTitle = True
    For j = 2 To 34
      .SetSourceData Sheet1.Range("$B$1:$I1," & Cells(j, 2).Resize(, 8).Address), 1
      .ChartTitle.Text = Cells(j, 1)
      .Parent.Copy
      pp.slides.Add(1, 12).Shapes.PasteSpecial 1
    Next
  End With
End Sub