Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Alle Diagramme aus mehreren Workbooks sammeln

Betrifft: Alle Diagramme aus mehreren Workbooks sammeln von: Alex
Geschrieben am: 09.03.2016 10:13:43

Hallo Zusammen,

habe einen Ordner mit mehreren *.xlsx Dateien. Jede der Dateien hat mehrere Arbeitsblätter auf denen z.T. Diagramme sind.

Wie kann ich sämtliche Sheets in allen diesen *.xlsx Dateien durchgehen und dann alle Digramme die z.B. im Diagrammnamen "TS" enthalten in eine neue *.xlsx Datei (auf das erste Sheet untereinander) oder/und nacheinander in ein neues Word-Dokument bringen?

Wäre sehr dankbar für eine Lösung, da es aktuelle ne Meeeeeenge händischer Aufwand ist.

Danke :-)

  

Betrifft: AW: Alle Diagramme aus mehreren Workbooks sammeln von: Beverly
Geschrieben am: 09.03.2016 11:35:09

Hi Alex,

versuche es ao:

Sub DiasKopieren()
    Dim strMappe As String
    Dim strPfad As String
    Dim wksTab As Worksheet
    Dim chrDia As ChartObject
    Dim lngZaehler As Long
    Dim dblOben As Double
    strPfad = "I:\Z_Test\"  '<== Pfad anpassen
    strMappe = Dir(strPfad & "*.xlsx")
    Application.ScreenUpdating = False
    With ThisWorkbook.Worksheets("Tabelle1")
        Do While strMappe <> ""
            Workbooks.Open Filename:=strPfad & strMappe
            For Each wksTab In ActiveWorkbook.Worksheets
                With wksTab
                    If .ChartObjects.Count > 0 Then
                        For Each chrDia In .ChartObjects
                            If InStr(chrDia.Name, "TS") > 0 Then
                                chrDia.Copy
                                ThisWorkbook.Worksheets("Tabelle1").Paste
                            End If
                        Next chrDia
                    End If
                End With
            Next wksTab
            ActiveWorkbook.Close True
            strMappe = Dir
        Loop
        .ChartObjects(1).Top = 0
        For lngZaehler = 2 To .ChartObjects.Count
            dblOben = .ChartObjects(lngZaehler - 1).Top + .ChartObjects(lngZaehler - 1).Height
            .ChartObjects(lngZaehler).Top = dblOben
        Next lngZaehler
    End With
    Application.ScreenUpdating = False
End Sub

GrußformelBeverly's Excel - Inn


  

Betrifft: AW: Alle Diagramme aus mehreren Workbooks sammeln von: Alex
Geschrieben am: 09.03.2016 14:02:08

Vielen Dank Karin,

allerdings wird ist das neu erzeugte File leer (anscheinend wird nichts eingefügt). Das Makro läuft sauber alle Dateien durch, kopiert aber nichts raus!?


  

Betrifft: AW: Alle Diagramme aus mehreren Workbooks sammeln von: Beverly
Geschrieben am: 09.03.2016 14:50:33

Hi Alex,

kann ich nicht nachvollziehen.

Führe mal nach dem Kopieren dieses Makro aus:

Sub DiaAnzahl()
    MsgBox ActiveSheet.ChartObjects.Count
End Sub

Falls als Ergebnis 0 ausgegeben wird, wurde tatsächlich nichts kopiert. Könnte es denn sein, dass in keinem der Diagramm-Namen "TS" steht?


GrußformelBeverly's Excel - Inn


  

Betrifft: AW: Alle Diagramme aus mehreren Workbooks sammeln von: Alex
Geschrieben am: 11.03.2016 14:38:22

Hi Beverly,

also da sind schon Chartobjects drin. Das Skript geht auch ordnungsgemäß alle Dateien durch. Allerdings gibts anscheinend ein Problem damit, welches Blatt beim Einfügen gerade aktiv ist.

Hab wie folgt angepasst:

If .ChartObjects.Count > 0 Then
    For Each chrDia In .ChartObjects
        If InStr(chrDia.Name, "TS") > 0 Then
            chrDia.Copy
            Workbooks(1).Sheets(1).Activate
            Workbooks(1).Sheets(1).Cells(1,1).Select  'Zelle "A1" im WB1/Sheet1 anwählen
            ActiveCell.Value = Workbooks(2).Name      'Dateiname der Quell-WB hineinschreiben
            Workbooks(1).Sheets(1).Cells(2,1).Select  'Zelle "A2" im WB1/Sheet1 anwählen
	    Workbooks(1).Worksheets(1).Paste          'Diagramm aus Quell-WB einfügen 
        End If
    Next chrDia
End IF
ABER: Ist natürlich bisschen unsauber da irgendwie zwieschen den Workbooks hin und her zu aktiveren. Das setzt nämlich voraus, dass das Workbook aus dem ich den Aufruf starte immer die Nr. 1 ist "Workbooks(1)" und das aus dem heraus kopiert wird immer die Nr. 2 "Workbooks(2)".
Kann man da nicht feste "Zeiger" auf die Workbooks definieren, mit denen man dann arbeitet?


  

Betrifft: AW: Alle Diagramme aus mehreren Workbooks sammeln von: Steve
Geschrieben am: 11.03.2016 15:06:12

Hallo Alex,

gleich vornweg, Beverly's Makro läuft bei mir wie eine eins. Warum bei dir nicht kann ich nicht nachvollziehen, glaube aber eher dass deine Diagramme nicht richtig benannt sind oder du den Diagrammtitel statt dem -Namen meinst.

Nichtsdestotrotz will ich dir zu deinem Problem der Workbooks ein paar Tipps geben:
Erstelle dir eine Variable von Typ Workbook und weise ihr beim Öffnen der Mappe gleich die entsprechende Mappe zu. Achtung die Attribute gehören dann in Klammern. Bsp.:

Dim wkb As Workbook
'...
Set wkb = Workbooks.Open(Filename:=strPfad & strMappe)
Dann kannst du die Ausgangsmappe mit "ThisWorkbook" und die geöffnete mit wkb ansprechen, ohne dir die Namen irgendwohin zu schreiben.

lg Steve


  

Betrifft: AW: Alle Diagramme aus mehreren Workbooks sammeln von: Beverly
Geschrieben am: 11.03.2016 16:30:24

Hi Alex,

sorry, habe keine Mailbenachrichtigung bekommen.

Es muss nicht zwischen den Blättern hin und her selektiert werden, denn in meinem Code wird korrekt auf die richtigen Blätter referenziert.

Die folgende Zeile

    With ThisWorkbook.Worksheets("Tabelle1")

beideutet, dass sich auf die Mappe mit dem Code und darin auf Tabelle1 bezogen wird - das ist das Zieltabellenblatt.

Beim Öffnen der Mappen aus dem Ordner, ist die betreffnende Mappe jeweils die aktive - das findest du in dieser Zeile
            For Each wksTab In ActiveWorkbook.Worksheets
in der mit der Schleife über alle Tabellenblätter der aktiven Mappe gelaufen wird und in der folgenden Zeile, wird sich stets auf das laufende Tabellenblatt der aktiven Mappe bezogen
 
                With wksTab

Somit ist alles korrekt.

Ich nehme aber an, dass deine Diagramme nicht "TS" im Namen beinhalten, weshalb keine kopiert werden - deshalb solltest du den Code aus meinem vorhergehenden beitrag mal ausführen: und zwar in der Arbeitsmappe, in die kopiert werden soll.

Wenn du also mit "Name" eventuell nicht den Diagrammnamen sondern den Diagrammtitel meinst, dann musst du den Code wie folgt ändern:
            For Each wksTab In ActiveWorkbook.Worksheets
                With wksTab
                    If .ChartObjects.Count > 0 Then
                        For Each chrDia In .ChartObjects
                            If chrDia.Chart.HasTitle Then
                                If InStr(chrDia.Name, "TS") > 0 Then
                                    chrDia.Copy
                                    ThisWorkbook.Worksheets("Tabelle1").Paste
                                End If
                            End If
                        Next chrDia
                    End If
                End With
            Next wksTab

GrußformelBeverly's Excel - Inn


  

Betrifft: AW: Alle Diagramme aus mehreren Workbooks sammeln von: Alex
Geschrieben am: 14.03.2016 09:41:36

Hi Karin,

Du hast Recht, mein Fehler! Ich habe meine Makros in einem Addin, das automatisch beim Öffnen von Excel geladen wird und von dem aus der Aufruf passiert. Habe den Aufruf also immer gemacht, wenn das leere Workbook gerade nicht aktiv war...

Jetzt passts!

Vielen Dank :-)


 

Beiträge aus den Excel-Beispielen zum Thema "Alle Diagramme aus mehreren Workbooks sammeln"