Antworten und eine Beispielarbeitsmappe zu Fragen zum Thema "Dateien" finden Sie hier: Hier klicken

Blätter aus einzelnen Dateien übertragen

Bewerten Sie hier bitte das Excel-Portal

Der kurze Weg zum Ziel: Auftragsprogrammierung

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

Blätter aus einzelnen Dateien übertragen

Blätter aus einzelnen Dateien übertragen von Paul vom 21.09.2020 10:03:43

AW: Blätter aus einzelnen Dateien übertragen - von fcs am 21.09.2020 13:11:23
- AW: Blätter aus einzelnen Dateien übertragen - von Paul am 23.09.2020 08:48:57
  - AW: Blätter aus einzelnen Dateien übertragen - von fcs am 23.09.2020 10:02:36
    - AW: Blätter aus einzelnen Dateien übertragen - von Paul am 23.09.2020 15:12:16
      - AW: Blätter aus einzelnen Dateien übertragen - von Paul am 23.09.2020 15:17:20
        
        AW: Blätter aus einzelnen Dateien übertragen - von fcs am 23.09.2020 21:42:30
        
        AW: Blätter aus einzelnen Dateien übertragen - von Paul am 24.09.2020 09:50:59
        
        AW: Blätter aus einzelnen Dateien übertragen - von fcs am 25.09.2020 14:39:03

Betrifft: Blätter aus einzelnen Dateien übertragen von: Paul
Geschrieben am: 21.09.2020 10:03:43

Hallo,

ich hänge gerade an folgendem Problem: Ich habe lauter Excel Dateien mit Makro in einem Ordner, in jeder einzelnen Datei (immer unterschiedlich benannt, aber gleich aufgebaut) möchte ich das Worksheet "Protokoll", welches ausgeblendet und mit einem Passwort geschützt ist in ein gesamtes Protokoll in einer neuen Datei übertragen.
Also im Idealfall habe ich danach eine Datei mit allen Protokollen der ca. 36 Dateien untereinander. Ist so etwas möglich?

Betrifft: AW: Blätter aus einzelnen Dateien übertragen
von: fcs
Geschrieben am: 21.09.2020 13:11:23

Hallo Paul,

hier ein entsprechendes Makro, um die Daten aus den Tabellenblättern in einem Blatt zusammenzufassen.

LG
Franz

Sub Protokolle_zusammenstellen()
    Dim varOrdner
    Dim xFilesToOpen As Variant
    Dim rngCopy As Range
    Dim Spa_L As Long, Zei_L As Long, zei_Z
    Dim xWb As Workbook, xSh As Worksheet
    Dim xTempWb As Workbook, xTempSh As Worksheet
    Dim StatusCalc As Long
    
    On Error GoTo ErrHandler
    
    With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "Bitte Ordner mit den Protokolldateien auswählen"
      If .Show = -1 Then
        varOrdner = .SelectedItems(1)
      Else
        Exit Sub
      End If
    End With
    
    With Application
      .ScreenUpdating = False
      StatusCalc = .Calculation
      .Calculation = xlCalculationManual
      .EnableEvents = False
    End With
    
    'Dateien im Ordner suchen
    xFilesToOpen = Dir(varOrdner & "\*.xlsm")
    Do Until xFilesToOpen = ""
      'Datei schreibgeschützt öffnen
      Set xTempWb = Application.Workbooks.Open(varOrdner & "\" & xFilesToOpen, ReadOnly:=True)
      For Each xTempSh In xTempWb.Worksheets
        If xTempSh.Visible <> xlSheetVisible Then
          xTempSh.Visible = xlSheetVisible
          With xTempSh.UsedRange
              Zei_L = .Row + .Rows.Count - 1
              Spa_L = .Column + .Columns.Count - 1
          End With
          With xTempSh
            Set rngCopy = .Range(.Cells(1, 1), .Cells(Zei_L, Spa_L))
          End With
          If xWb Is Nothing Then
            'Ziel-Datei suchen/Setzen - Neue Mappe mit einem Blatt anlegen
            Set xWb = Application.Workbooks.Add(Template:=xlWBATWorksheet)
            Set xSh = xWb.Worksheets(1)
            xSh.Name = "Protokolle"
            rngCopy.EntireColumn.Copy
            zei_Z = 1
            xSh.Cells(zei_Z, 1).PasteSpecial Paste:=xlPasteColumnWidths
            
          End If
          rngCopy.Copy
          xSh.Cells(zei_Z, 1).PasteSpecial Paste:=xlPasteFormats
          xSh.Cells(zei_Z, 1).PasteSpecial Paste:=xlPasteValues
          zei_Z = zei_Z + rngCopy.Rows.Count
          Application.CutCopyMode = False
          Exit For
        End If
      Next
      xTempWb.Close savechanges:=False
      Set xTempWb = Nothing
      xFilesToOpen = Dir
    Loop
    
ExitHandler:
    With Application
      .ScreenUpdating = True
      .Calculation = StatusCalc
      .EnableEvents = True
    End With
    Exit Sub
    
ErrHandler:
    MsgBox "Fehler-Nr.: " & Err.Number & vbLf & Err.Description, , "Error!"
    If Not xTempWb Is Nothing Then
      xTempWb.Close savechanges:=False
    End If
    Resume ExitHandler
End Sub

Betrifft: AW: Blätter aus einzelnen Dateien übertragen
von: Paul
Geschrieben am: 23.09.2020 08:48:57

Vielen Dank für deine Hilfe, allerdings wird mir nur ein leerer Ordner angezeigt (wo aber meine Dateien zum zusammenführen enthalten sind). Woran kann das liegen?

Betrifft: AW: Blätter aus einzelnen Dateien übertragen
von: fcs
Geschrieben am: 23.09.2020 10:02:36

Hallo Paul,

das Makro ist so gestrickt, dass es alle Dateien mit der Erweiterung "xlsm" in dem gewählten Ordner sucht und dann die Dateien öffnet und aus dem Tabellenblatt die Daten kopiert.

Wenn du gezielt nur bestimmte Dateien auswählen möchtest, dann muss der Dialog mit einem anderen Parameter angezeigt werden und die Schleife zum Abarbeiten der Dateien angepasst werden.

LG
Franz

Betrifft: AW: Blätter aus einzelnen Dateien übertragen
von: Paul
Geschrieben am: 23.09.2020 15:12:16

Ah, ok! Entschuldige, jetzt habe ich es verstanden.
Das Problem jetzt ist nur noch, dass es nicht das erste ausgeblendete Blatt ist, sondern das 4. ausgeblendete und das 7. gesamt. Wo müsste ich das im COde ändern?

Betrifft: AW: Blätter aus einzelnen Dateien übertragen
von: Paul
Geschrieben am: 23.09.2020 15:17:20

Bzw. noch eine andere Frage, es muss keine neue Arbeitsmappe aufmachen, es kann die Tabellen in der aktuell geöffneten zusammenführen, ich glaube das erleichtert das ständige zusammenführen.
Ist das irgendwie möglich?

Betrifft: AW: Blätter aus einzelnen Dateien übertragen
von: fcs
Geschrieben am: 23.09.2020 21:42:30

Hallo Paul,

Das Problem jetzt ist nur noch, dass es nicht das erste ausgeblendete Blatt ist, sondern das 4. ausgeblendete und das 7. gesamt. Wo müsste ich das im COde ändern?
Wenn es immer das 7. Blatt ist, dann kann man es im Code fest vorgeben und die For-Each-Schleife und die Prüfung auf sichtbar kann entfallen.

Bzw. noch eine andere Frage, es muss keine neue Arbeitsmappe aufmachen, es kann die Tabellen in der aktuell geöffneten zusammenführen, ich glaube das erleichtert das ständige zusammenführen.
Ist das irgendwie möglich?
Kein Problem, die Zieldatei und das Zielblatt kann man auch fix vorgeben. Du musst dann einmalig die Spaltenbreiten im Zielblatt formatieren und im Code den von mir vorgegeben Blattnamen übernehmen oder im Code anpassen.

Hoffe so passt es jetzt.
LG
Franz

Sub Protokolle_zusammenstellen()
    Dim varOrdner
    Dim xFilesToOpen As Variant
    Dim rngCopy As Range
    Dim Spa_L As Long, Zei_L As Long, zei_Z
    Dim xWb As Workbook, xSh As Worksheet
    Dim xTempWb As Workbook, xTempSh As Worksheet
    Dim StatusCalc As Long
    
    On Error GoTo ErrHandler
    
    With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "Bitte Ordner mit den Protokolldateien auswählen"
      If .Show = -1 Then
        varOrdner = .SelectedItems(1)
      Else
        Exit Sub
      End If
    End With
    
    With Application
      .ScreenUpdating = False
      StatusCalc = .Calculation
      .Calculation = xlCalculationManual
      .EnableEvents = False
    End With
    
    'Ziel-Datei setzen
    Set xWb = ActiveWorkbook
    'Ziel-Tabellenblatt setzen
    Set xSh = xWb.Worksheets("Protokolle")          'Name ggf anpassen
    With xSh
        zei_Z = .UsedRange.Row + .UsedRange.Rows.Count - 1
        If Not IsEmpty(.Cells(zei_Z, 1)) Then zei_Z = zei_Z + 1
    End With
    'Dateien im Ordner suchen
    xFilesToOpen = Dir(varOrdner & "\*.xlsm")
    Do Until xFilesToOpen = ""
      'Datei schreibgeschützt öffnen
      Set xTempWb = Application.Workbooks.Open(varOrdner & "\" & xFilesToOpen, ReadOnly:=True)
      Set xTempSh = xTempWb.Sheets(7)     'Nummer des Registers ggf. anpassen
      
      xTempSh.Visible = xlSheetVisible
      
      With xTempSh.UsedRange
          Zei_L = .Row + .Rows.Count - 1
          Spa_L = .Column + .Columns.Count - 1
      End With
      With xTempSh
        Set rngCopy = .Range(.Cells(1, 1), .Cells(Zei_L, Spa_L))
      End With
      rngCopy.Copy
      xSh.Cells(zei_Z, 1).PasteSpecial Paste:=xlPasteFormats
      xSh.Cells(zei_Z, 1).PasteSpecial Paste:=xlPasteValues
      zei_Z = zei_Z + rngCopy.Rows.Count
      
      Application.CutCopyMode = False
      
      xTempWb.Close savechanges:=False
      Set xTempWb = Nothing
      xFilesToOpen = Dir
    Loop
    
ExitHandler:
    With Application
      .ScreenUpdating = True
      .Calculation = StatusCalc
      .EnableEvents = True
    End With
    Exit Sub
    
ErrHandler:
    MsgBox "Fehler-Nr.: " & Err.Number & vbLf & Err.Description, , "Error!"
    If Not xTempWb Is Nothing Then
      xTempWb.Close savechanges:=False
    End If
    Resume ExitHandler
End Sub

Betrifft: AW: Blätter aus einzelnen Dateien übertragen
von: Paul
Geschrieben am: 24.09.2020 09:50:59

Wow! Vielen Dank!
Es funktioniert. Aktuell nimmt er leider noch viele leere Zeilen in das Protokoll in dem es die Dateien zusammen führt und immer wieder die Überschrift - die braucht es eigentlich nur einmal.

Betrifft: AW: Blätter aus einzelnen Dateien übertragen
von: fcs
Geschrieben am: 25.09.2020 14:39:03

Hallo Paul,

hier das Makro nochmals erweitert,

- Titelzeile wird nur kopiert, wenn noch keine Daten im Zielblatt vorhanden

- leere Zeilen bzw. Zeilen, die nur Leerzeichen enthalten werden gelöscht.

LG
Franz

Sub Protokolle_zusammenstellen()
    Dim varOrdner
    Dim xFilesToOpen As Variant
    Dim rngCopy As Range
    Dim spa As Long, Spa_L As Long, Zei_L As Long, zei_Z
    Dim xWb As Workbook, xSh As Worksheet
    Dim xTempWb As Workbook, xTempSh As Worksheet
    Dim StatusCalc As Long
    Dim bolStatus As Boolean, Zeile_1 As Long
    
    On Error GoTo ErrHandler
    
    With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "Bitte Ordner mit den Protokolldateien auswählen"
      If .Show = -1 Then
        varOrdner = .SelectedItems(1)
      Else
        Exit Sub
      End If
    End With
    
    With Application
      .ScreenUpdating = False
      StatusCalc = .Calculation
      .Calculation = xlCalculationManual
      .EnableEvents = False
    End With
    
    'Ziel-Datei setzen
    Set xWb = ActiveWorkbook
    'Ziel-Tabellenblatt setzen
    Set xSh = xWb.Worksheets("Protokolle")          'Name ggf anpassen
    With xSh
        zei_Z = .UsedRange.Row + .UsedRange.Rows.Count - 1
        If Not IsEmpty(.Cells(zei_Z, 1)) Then
          zei_Z = zei_Z + 1
          bolStatus = False
        Else
          bolStatus = True 'Titelzeile mit kopieren
        End If
        Zeile_1 = zei_Z
    End With
    'Dateien im Ordner suchen
    xFilesToOpen = Dir(varOrdner & "\*.xlsm")
    Do Until xFilesToOpen = ""
      'Datei schreibgeschützt öffnen
      Set xTempWb = Application.Workbooks.Open(varOrdner & "\" & xFilesToOpen, ReadOnly:=True)
      Set xTempSh = xTempWb.Sheets(7)     'Nummer des Registers ggf. anpassen
      
      xTempSh.Visible = xlSheetVisible
      
      With xTempSh.UsedRange
          Zei_L = .Row + .Rows.Count - 1
          Spa_L = .Column + .Columns.Count - 1
      End With
      With xTempSh
        If bolStatus = True Then
          'Titelzeile mit kopieren
          Set rngCopy = .Range(.Cells(1, 1), .Cells(Zei_L, Spa_L))
          bolStatus = False
        Else
          'Titelzeile nicht mit kopieren
          Set rngCopy = .Range(.Cells(2, 1), .Cells(Zei_L, Spa_L))
        End If
      End With
      rngCopy.Copy
      xSh.Cells(zei_Z, 1).PasteSpecial Paste:=xlPasteFormats
      xSh.Cells(zei_Z, 1).PasteSpecial Paste:=xlPasteValues
      zei_Z = zei_Z + rngCopy.Rows.Count
      
      Application.CutCopyMode = False
      
      xTempWb.Close savechanges:=False
      Set xTempWb = Nothing
      xFilesToOpen = Dir
    Loop
    
    'leere Zeilen erfassen und löschen
    With xSh
      Set rngCopy = Nothing
      Zei_L = zei_Z - 1
      For zei_Z = Zei_L To Zeile_1 Step -1
        bolStatus = False
        For spa = 1 To Spa_L
          If Trim(.Cells(zei_Z, spa).Text) <> "" Then
            bolStatus = True
            Exit For
          End If
        Next
        If bolStatus = False Then
          If rngCopy Is Nothing Then
            Set rngCopy = .Rows(zei_Z)
          Else
            Set rngCopy = Application.Union(rngCopy, .Rows(zei_Z))
          End If
        End If
      Next
      If Not rngCopy Is Nothing Then
        rngCopy.Delete
      End If
    End With
    
ExitHandler:
    With Application
      .ScreenUpdating = True
      .Calculation = StatusCalc
      .EnableEvents = True
    End With
    Exit Sub
    
ErrHandler:
    MsgBox "Fehler-Nr.: " & Err.Number & vbLf & Err.Description, , "Error!"
    If Not xTempWb Is Nothing Then
      xTempWb.Close savechanges:=False
    End If
    Resume ExitHandler
End Sub