Clever-Excel-Forum

Hallo Zusammen, ich bräuchte etwas hilfe. Ich komme leider nicht weiter. Ich möchte gerne _ mehrere Arbeitsblätter aus verschiedensten Unterordern zu einem Arbeitsblatt zusammen führen. Die Dateien bekomme ich alle geöffnet, es kopiert mir aber immer den Arbeitsblatt-Inhalt aller Datein in A1 des aktuellen Arbeitsblattes, es soll aber immer am Ende des jeweiligen Datensatzes angehängt werden. zB 1 Blatt auf A1 und 2 Blatt dann ans Ende zB A3.

Code:
Sub Vereinigung()

    Call ListFilesInFolder("c:\Irgendwas")

End Sub

Sub ListFilesInFolder(SourceFolderName As String)

    Dim SourceFolder As Object, SubFolder As Object, nextsheet

    Dim Datei$, Pfad$, DateiMatch$

    Dim AnfZelle As Range, Wb As Workbook, datensatz As Worksheet, lo As ListObject, mainLO As ListObject, col As ListRow

    Dim counter As Integer

    On Error Resume Next

    Set SourceFolder = CreateObject("Scripting.FileSystemObject").GetFolder(SourceFolderName)

    Set datensatz = Worksheets("Datensatz") 'welches Arbeitsblatt sollen die Daten  zwischengespeichert werden

    Set ergebnis = Worksheets("Ergebnis")  'welches Arbeitsblatt für die Erstellung der Liste

    datensatz.Cells.ClearContents          'Zellen im Arbteitsblatt leeren

    Dateiname$ = "datenpool.xls" 'Dateinamen

    nextsheet = Dir(SourceFolder.Path & "\" & Dateiname$)

    counter = 1

    Set AnfZelle = datensatz.Range("A" & counter) '<== Anfangszelle im aktiven Arbeitsblatt der aktiven Arb.Mappe

    Do While nextsheet <> ""

        Workbooks.Open SourceFolder.Path & "\" & nextsheet

        ActiveWorkbook.Worksheets("Sheet1").Range("A1:A6").Copy Destination:=AnfZelle

        ActiveWorkbook.Close SaveChanges:=False    

        nextsheet = Dir()

        counter = counter + 1

    Loop

    For Each SubFolder In SourceFolder.SubFolders

        ListFilesInFolder SubFolder.Path

    Next SubFolder

    Set SourceFolder = Nothing

    Set SubFolder = Nothing

End Sub

Hallo

dieser Code ist meines Wissens ein Rekursives Programm. Es ruft sich im Unterprogramm selbst auf, startet im 2. For Next von neu!
Wenn man dann die Ziel Tabelle jedesmal wieder löscht, und den Counter jedesmal auf 1 setzt, kann der Code nicht einwandfrei laufen!

mfg Gast 123

Code:
Sub Vereinigung()

    'Zellen im Arbteitsblatt leeren

    Worksheets("Datensatz").Cells.ClearContents

    Call ListFilesInFolder("c:\Irgendwas")

End Sub

Sub ListFilesInFolder(SourceFolderName As String)

    Dim SourceFolder As Object, SubFolder As Object, nextsheet

    Dim Datei$, Pfad$, DateiMatch$

    Dim AnfZelle As Range, Wb As Workbook, datensatz As Worksheet, lo As ListObject, mainLO As ListObject, col As ListRow

    Dim counter As Integer

    On Error Resume Next

    Set SourceFolder = CreateObject("Scripting.FileSystemObject").GetFolder(SourceFolderName)

    Set datensatz = Worksheets("Datensatz") 'welches Arbeitsblatt sollen die Daten  zwischengespeichert werden

    Set ergebnis = Worksheets("Ergebnis")  'welches Arbeitsblatt für die Erstellung der Liste

    '** No!! datensatz.Cells.ClearContents          'Zellen im Arbteitsblatt leeren

    Dateiname$ = "datenpool.xls" 'Dateinamen

    nextsheet = Dir(SourceFolder.Path & "\" & Dateiname$)

    counter = datensatz.Cells(rwos.Count, 1).End(xlUp).Row

    If counter > 1 Then counter = counter + 1  'NextZelle

    Set AnfZelle = datensatz.Range("A" & counter) '<== Anfangszelle im aktiven Arbeitsblatt der aktiven Arb.Mappe

    Do While nextsheet <> ""

        Workbooks.Open SourceFolder.Path & "\" & nextsheet

        ActiveWorkbook.Worksheets("Sheet1").Range("A1:A6").Copy Destination:=AnfZelle

        ActiveWorkbook.Close SaveChanges:=False

        nextsheet = Dir()

    Loop

    For Each SubFolder In SourceFolder.SubFolders

        '** hier startet das Programm weider von neu (Rekursiv) 

        ListFilesInFolder SubFolder.Path

    Next SubFolder

    Set SourceFolder = Nothing

    Set SubFolder = Nothing

End Sub

Danke vielmals für den Tip, das leuchtet ein. Allerdings ändert sich nichts, es wird nachwievor alles auf A1 eingefügt, entsprechend auch wieder überschrieben. Vieleicht ein Tip, oder eine andere Idee?

Hallo

Sorry, kleiner Denkfehler von mir. Der Counter für die LastZell Suche muss IN die Do Loop Schleife, nicht davor. Bitte den Teil korrigieren

mfg Gast 123

Code:
    On Error Resume Next

    Set SourceFolder = CreateObject("Scripting.FileSystemObject").GetFolder(SourceFolderName)

    Set datensatz = Worksheets("Datensatz") 'welches Arbeitsblatt sollen die Daten  zwischengespeichert werden

    Set ergebnis = Worksheets("Ergebnis")  'welches Arbeitsblatt für die Erstellung der Liste

    '** No!! datensatz.Cells.ClearContents          'Zellen im Arbteitsblatt leeren

    Dateiname$ = "datenpool.xls" 'Dateinamen

    nextsheet = Dir(SourceFolder.Path & "\" & Dateiname$)

    Do While nextsheet <> ""

        counter = datensatz.Cells(rwos.Count, 1).End(xlUp).Row

        If counter > 1 Then counter = counter + 1

        Workbooks.Open SourceFolder.Path & "\" & nextsheet

        Set AnfZelle = datensatz.Range("A" & counter) '<== Anfangszelle im aktiven Arbeitsblatt der aktiven Arb.Mappe

        ActiveWorkbook.Worksheets("Sheet1").Range("A1:A6").Copy Destination:=AnfZelle

        ActiveWorkbook.Close SaveChanges:=False

        nextsheet = Dir()

    Loop

Code:
counter = datensatz.Cells(rwos.Count, 1).End(xlUp).Row

Es ist ein einfacher Schreibfehler gewesen, habe es jetzt eben erst bemerkt! :21: Vielen Dank für die Überarbeitung
Fehler: rwos -> korrekt rows

Code:
counter = datensatz.Cells(rows.Count, 1).End(xlUp).Row

kauter

Gast 123

kauter

Gast 123

kauter