Aus einer Datenbasis mehrere Diagramme in einer Übersicht erstellen!

[chris-ka]

Hallo,
ich habe eine Supportanfrage bekommen wo ich gerne Eure Vorschläge einholen möchte.
Gegeben ist eine Datenbasis mit ca. 10 000 Zeilen und ~ 20 Spalten, daraus werden mittels Pivot, Diagramme erzeugt.
Wobei die einzelnen Auswahlkriterien im Filter für die Diagrammerstellung zuständig sind.
Diese Diagramme müssen alle in einem Übersichtsblatt dargestellt werden.
Der Vorgang sollte automatisierbar sein, da jede Woche so eine Auswertung erzeugt werden sollte.
 
Was ich schon versucht habe:
30+ Pivottabels zu erzeugen und jeweils davon ein Diagramm zu erzeugen..... übersteigt die benötigte Rechenleistung der Zielrechner.
Jetzt immer einen Screenshoot vom Diagramm zu erzeugen, tja…
Was meint Ihr?
Hat schon jemand ähnliches gemacht?

Anbei noch eine vereinfachte Demo.

  demodatei.xlsx (Größe: 139,54 KB / Downloads: 5)

[Fennek]

Hallo Chris,

führe den Makro "T_1" einmal aus, danach den "T_2" im Einzelschrittmodus.

Das Kopieren und Plazieren der Charts ist dann nicht mehr so schwer.

Code:

Sub T_1()
Dim WS As Worksheet: Set WS = Sheets("Daten")
WS.Range("C1:C300").AdvancedFilter xlFilterCopy, , Sheets("Pivot").Cells(1, "K"), True
End Sub
Sub T_2()
For i = 2 To 8
    ActiveSheet.PivotTables("PivotTable2").PivotFields("Land").ClearAllFilters
    ActiveSheet.PivotTables("PivotTable2").PivotFields("Land").CurrentPage = Cells(i, "K").Value
Next i
End Sub

mfg

(so geht es nur in der gezeigten Datei, die notwendigen Änderungen sind aber mnimal)

[Fennek]

Hallo,

eigentlich wollte ich erst einmal eine Reaktion abwarten, aber

Code:

Sub F_en()

With Sheets("Daten")
    lr = .Cells(Rows.Count, 3).End(xlUp).Row
    .Range("C1:C" & lr).AdvancedFilter xlFilterCopy, , Sheets("Pivot").Cells(1, "K"), True
End With

With Sheets("Pivot")
For i = 2 To 8
    .PivotTables("PivotTable2").PivotFields("Land").ClearAllFilters
    .PivotTables("PivotTable2").PivotFields("Land").CurrentPage = .Cells(i, "K").Value
    .ChartObjects("Chart 1").Copy
        With Sheets("Test")
            .Pictures.Paste.Select
            If (i - 1) Mod 2 Then
                R = 5 + Int((i - 1) / 2) * 19
                C = 1
            Else
                C = 8
            End If
            Selection.Top = .Cells(R, C).Top
            Selection.Left = .Cells(R, C).Left
        End With
Next i
End With

End Sub

mfg

[chris-ka]

Hi,

danke!

:), das jemand gleich einen Code schreibt hätte ich gar nicht erwartet.
Sorry für das späte Feedback, aber gestern müsste ich gleich mal dienstlich weg und heute habe ich mal getestet.

so könnte es tatsächlich funktionieren, toll!
Vielen Dank für den Input und Code.

Für die Demodatei habe ich den Code ein wenig ergänzt. In der Originaldatei sind zwei Pivotcharts aus zwei Mappen zum Verteilen auf einer Übersicht, aber das sollte schon funktionieren.

Anbei noch der Code für die Demo

Code:

Option Explicit
Dim AppCalc
Dim AppScreen
Dim AppEvents
Sub Fe_n()
Dim lr As Long, i As Integer
Dim intR As Integer, IntC As Integer
Dim intCountC As Integer
Dim objCh As Object
Call speed_up
On Error Resume Next
Sheets("Übersicht").Delete
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Übersicht"
On Error GoTo 0
On Error GoTo errmsg
With Sheets("Daten")
    lr = .Cells(Rows.Count, 3).End(xlUp).Row
    .Range("C1:C" & lr).AdvancedFilter xlFilterCopy, , Sheets("Pivot").Cells(1, "K"), True
End With

With Sheets("Pivot")
    intCountC = .Cells(.Rows.Count, "K").End(xlUp).Row
    For i = 2 To intCountC
        .PivotTables("PivotTable2").PivotFields("Land").ClearAllFilters
        .PivotTables("PivotTable2").PivotFields("Land").CurrentPage = .Cells(i, "K").Value
        .ChartObjects("Chart 1").Copy
            With Sheets("Übersicht")
                 Set objCh = .Pictures.Paste
                If (i - 1) Mod 2 Then
                    intR = 5 + Int((i - 1) / 2) * 19
                    IntC = 1
                Else
                    IntC = 8
                End If
                objCh.Top = .Cells(intR, IntC).Top
                objCh.Left = .Cells(intR, IntC).Left
            End With
    Next i
End With
errmsg:
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
Call current_App
End Sub

Public Sub speed_up()
    With Application
        AppCalc = .Calculation
        AppScreen = .ScreenUpdating
        AppEvents = .EnableEvents
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
End Sub
Public Sub current_App()
    With Application
        .EnableEvents = AppEvents
        .Calculation = AppCalc
        .ScreenUpdating = AppScreen
        .DisplayAlerts = True
    End With
End Sub

[snb]

Diese Code reicht:

Code:

Sub M_snb()
   Sheets("Übersicht").Shapes.SelectAll
   Selection.Delete
    
    With Sheets("pivot").PivotTables("PivotTable2").PivotFields("Land")
       For Each it In .PivotItems
        .CurrentPage = it.Value

        .Parent.Parent.ChartObjects(1).CopyPicture
        With Sheets("Übersicht")
            .Paste .Cells(4 + 20 * (.Shapes.Count \ 2), 1 + 8 * (.Shapes.Count Mod 2))
        End With
       Next
    End With
End Sub

[chris-ka]

Hi,

danke!
Werde ich noch zum Teil adaptieren.

lg