Mehrere Dateien aus Ordner in einer Datei zusammenführen

[RobertH]

Hallo liebes Forum!

Ich habe (quasi täglich) einen (neuen) Ordner mit 50-100 Excellisten.

Diese Liste haben alle nur wenige Zeilen und alle dieselben Spalten A-Z.

Diese manuell zu einer Datei zusammenzufügen ist immer recht mühselig ...

Gibt es eine Möglichkeit diese "in einem Rutsch" zusammenzufügen?

Also ich würde alle neuen Listen z.B. in den Ordner C:\Users\Name\Documents\All-in-one packen, (nachdem ich die alten rausgenommen habe) und dann quasi per Knopfdruck eine Gesamtdatei erzeugen, die auch in diesen Ordner gespeichert wird.

Vielen Dank für eure Hilfe ...

Robert

[Stoffo]

Moin,

probiere es doch mal mittels Daten - Daten abrufen - Aus Datei - Aus Ordner - Daten Tansformieren und kombinieren

[UweD]

Hallo

Möchtest du für jede Datei in der Zusammenfassung einen eigenen Reiter erstellen, oder sollen die vorhandenen Daten in Einem Reiter (Tabellenblatt) alle untereinander eingetragen werden ?

Haben die Einzeldaten jeweils eine Überschrift?


LG UweD

[RobertH]

Hi Stoffo ...

Ich habe:

Daten - Neue Abfrage - Aus Datei - Aus Ordner - Daten Tansformieren und kombinieren habe ich nicht ... nur bearbeiten

[Stoffo]

Moin,

schau mal hier unter Importieren aus Excel oder Access:

Link

Je nachdem bei welchem Schritt ein Problem auftritt kannst du dich dann ja nochmal melden.

[RobertH]

Hallo Uwe ...

Danke das Du (nach-)gefragt hast.

Die vorhandenen Daten sollen in einem Reiter (Tabellenblatt) alle untereinander eingetragen werden.

Die Bezeichnungen an sich sind immer gleich ... nur kommen manche in manchen Dateien nicht vor.

Aber die 5 Spalten die ich eigentlich nur benötige kommen immer vor.

Die ersten drei sind immer in Spalte B, C, D nur die letzten beiden mal in E, mal in F oder G ...

Könnte man auch nur diese 5 immer gleich bezeichneten Spalten auslesen und zusammenführen?

[UweD]

Hallo nochmal


so?

Code:

Option Explicit

Sub Zusammen1()
    Dim TBZ As Worksheet
    Dim Pfad As String, Datei As String, Ext As String
    Dim Spalte As Integer, LRZ As Long, LRx As Long, Z1 As Integer
    Dim SW, I As Integer, Anz As Integer
   
    Set TBZ = ThisWorkbook.Sheets("Tabelle1") ' Zieltabelle
   
    Z1 = 2 'ggf wegen Überschrift
   
    'Suchworte für Spalte 4 und 5
    SW = Array("ABC", "DEF")
   
   
    Pfad = "C:\Users\Name\Documents\All-in-one"
   
    Ext = "*.xlsx"
   
    Pfad = IIf(Right(Pfad, 1) = "\", Pfad, Pfad & "\") 'sicherstellen, dass \ am Ende
   
    Datei = Dir(Pfad & Ext)
   
    Application.ScreenUpdating = False 'Schaltet flackern ab
   
    'Reset
    TBZ.Cells.Delete
   
    Do While Datei <> ""
       
        Workbooks.Open Filename:=Pfad & Datei
       
        With ActiveWorkbook.Sheets(1)
       
            LRx = .Cells(.Rows.Count, "B").End(xlUp).Row 'letzte Zeile der Spalte

            LRZ = TBZ.Cells(TBZ.Rows.Count, "B").End(xlUp).Row + 1
           
            'B2:D.. Kopieren in
            .Cells(Z1, 2).Resize(LRx - Z1 + 1, 3).Copy TBZ.Cells(LRZ, 2)
           
            For I = LBound(SW) To UBound(SW) ' Schleife für Suchworte (0 bis 1)
                'Spalte suchen
                If WorksheetFunction.CountIf(.Rows(1), SW(I)) > 0 Then
                    Spalte = WorksheetFunction.Match(SW(I), .Rows(1), 0)
                   
                    'kopieren
                    .Cells(Z1, Spalte).Resize(LRx - Z1 + 1, 1).Copy TBZ.Cells(LRZ, 5 + I) 'Rest Kopieren in E und F
               
                Else
                    MsgBox "In Datei: " & Datei & " wurde Suchwort " & SW(I) & " nicht gefunden"
                End If
            Next
            Anz = Anz + 1
        End With
       
        Workbooks(Datei).Close False
       
        ' wenn gewünscht Datei nachher löschen
        'Kill Pfad & Datei
       
        Datei = Dir() ' nächste Datei
    Loop
    MsgBox Anz & " Dateien zusammengefügt"
End Sub

LG UweD

[RobertH]

Hallo Uwe ...

das sieht ja wahnsinnig erfolgversprechend aus.

Wenn ich das richtig deute werden die Spalten B, C und D immer genommen richtig?

Und die Suchworte = Überschriften für die Ergebnisspalte 4 und 5 ersetze ich bei "ABC" und "DEF" richtig?

Nur wie bekomme ich diesen Code dann zum Laufen?

[UweD]

Hallo

ja genau.


- Alt+F11 startet den VB Editor
- dort Einfügen, Modul
- rechts den Code einfügen

- VBEditor kannst du wieder schließen

- Über Alt+F8 lässt du dir die Makros anzeigen
- "Zusammen1" kannst du dann markieren
- Entweder direkt AUSFÜHREN
- Oder über die OPTIONEN einer Tastenkombi zuordnen
- Oder einen Button erzeugen und das Makro zuweisen.


LG

[RobertH]

Hi Uwe ...

Danke für die verständliche Anleitung.

Ich habe das Einfügen des Codes geschafft und auch die ersten Fehlermeldungen überwunden, nur jetzt komme ich nicht weiter ...

Laufzeitfehler: 1004

Die Zeile markiert mir der Debugger gelb:

.Cells(Z1, 2).Resize(LRx - Z1 + 1, 3).Copy TBZ.Cells(LRZ, 2)

1. Der Pfad zum Ordner ist und der Name des Ordners sind korrekt?
2. Die zusammenzuführenden Dateien sind in diesem Ordner
3. Die Zieldatei Tabelle1 ist auch in diesem Ordner?
4. Die Suchworte 4&5 habe ich umbenannt
5. Die Datei mit dem Makro habe ich "Makro" genannt, auch in diesem Ordner

P.S. "Name" im Pfad ist natürlich nur ein Platzhalter ...

Code:

Option Explicit

Sub Zusammen1()
    Dim TBZ As Worksheet
    Dim Pfad As String, Datei As String, Ext As String
    Dim Spalte As Integer, LRZ As Long, LRx As Long, Z1 As Integer
    Dim SW, I As Integer, Anz As Integer
  
    Set TBZ = ThisWorkbook.Sheets("Tabelle1") ' Zieltabelle
  
    Z1 = 2 'ggf wegen Überschrift
  
    'Suchworte für Spalte 4 und 5
    SW = Array("location-contacts", "ng-binding 3")
  
  
    Pfad = "C:\Users\Name\Documents\All-in-one"
  
    Ext = "*.xlsx"
  
    Pfad = IIf(Right(Pfad, 1) = "\", Pfad, Pfad & "\") 'sicherstellen, dass \ am Ende
  
    Datei = Dir(Pfad & Ext)
  
    Application.ScreenUpdating = False 'Schaltet flackern ab
  
    'Reset
    TBZ.Cells.Delete
  
    Do While Datei <> ""
      
        Workbooks.Open Filename:="C:\Users\Name\Documents\All-in-one\Tabelle1"
      
        With ActiveWorkbook.Sheets(1)
      
            LRx = .Cells(.Rows.Count, "B").End(xlUp).Row 'letzte Zeile der Spalte

            LRZ = TBZ.Cells(TBZ.Rows.Count, "B").End(xlUp).Row + 1
          
            'B2:D.. Kopieren in
            .Cells(Z1, 2).Resize(LRx - Z1 + 1, 3).Copy TBZ.Cells(LRZ, 2)
          
            For I = LBound(SW) To UBound(SW) ' Schleife für Suchworte (0 bis 1)
                'Spalte suchen
                If WorksheetFunction.CountIf(.Rows(1), SW(I)) > 0 Then
                    Spalte = WorksheetFunction.Match(SW(I), .Rows(1), 0)
                  
                    'kopieren
                    .Cells(Z1, Spalte).Resize(LRx - Z1 + 1, 1).Copy TBZ.Cells(LRZ, 5 + I) 'Rest Kopieren in E und F
              
                Else
                    MsgBox "In Datei: " & Datei & " wurde Suchwort " & SW(I) & " nicht gefunden"
                End If
            Next
            Anz = Anz + 1
        End With
      
        Workbooks(Datei).Close False
      
        ' wenn gewünscht Datei nachher löschen
        'Kill Pfad & Datei
      
        Datei = Dir() ' nächste Datei
    Loop
    MsgBox Anz & " Dateien zusammengefügt"
End Sub