Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Aus einer Datenbasis mehrere Diagramme in einer Übersicht erstellen!
#1
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.

.xlsx   demodatei.xlsx (Größe: 139,54 KB / Downloads: 5)
lg Chris
Feedback nicht vergessen.
3a2920576572206973742064656e20646120736f206e65756769657269672e
 [Bild: v.gif]

Antwortento top
#2
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)
[-] Folgende(r) 1 Benutzer sagt Danke an Fennek für diesen Beitrag:
  • chris-ka
Antwortento top
#3
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
[-] Folgende(r) 1 Benutzer sagt Danke an Fennek für diesen Beitrag:
  • chris-ka
Antwortento top
#4
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
lg Chris
Feedback nicht vergessen.
3a2920576572206973742064656e20646120736f206e65756769657269672e
 [Bild: v.gif]

Antwortento top
#5
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
Zum übersetzen von Excel Formeln:

http://dolf.trieschnigg.nl/excel/index.p...gids=en+de
[-] Folgende(r) 1 Benutzer sagt Danke an snb für diesen Beitrag:
  • chris-ka
Antwortento top
#6
Hi,

danke!
Werde ich noch zum Teil adaptieren.

lg
lg Chris
Feedback nicht vergessen.
3a2920576572206973742064656e20646120736f206e65756769657269672e
 [Bild: v.gif]

Antwortento top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste