Clever-Excel-Forum

Hi zusammen,

ich möchte mehrere Excel Dateien miteinander kombinieren und deren Inhalt in eine Masterdatei schreiben.
Hierfür habe ich auch bereits Code der wunderbar funktioniert.
Es gibt nur einen Haken: Ich muss für jede weitere Spalte, die ich kopieren möchte eine weitere Zeile Code einfügen. (Manche meiner Dateien haben allerdings 60 Spalten :19: )
Dieses Problem würde ich gerne mit einer Art Schleife beheben.

Hat hierfür jemand eine Idee?

Code:
Sub getData()

Dim wb As Workbook, ws As Worksheet

Set fso = CreateObject("Scripting.FileSystemObject")

Set fldr = fso.GetFolder("C:\temp\Test") 'Bitte Pfad ändern

y = ThisWorkbook.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1

For Each wbFile In fldr.Files

    If fso.GetExtensionName(wbFile.Name) = "xlsx" Then

     Set wb = Workbooks.Open(wbFile.Path)

     For Each ws In wb.Sheets

          wsLR = ws.Cells(Rows.Count, 1).End(xlUp).Row

       For x = 2 To wsLR

           ThisWorkbook.Sheets("sheet1").Cells(y, 1) = ws.Cells(x, 1)

            ThisWorkbook.Sheets("sheet1").Cells(y, 2[/b]) = ws.Cells(x, 2) 

          ThisWorkbook.Sheets("sheet1").Cells(y, 3[/b]) = ws.Cells(x, 3) 

          ThisWorkbook.Sheets("sheet1").Cells(y, 4[/b]) = ws.Cells(x, 4) 

           y = y + 1

          Next x

     Next ws

      wb.Close

    End If

Next wbFile

End Sub

Viele Grüße
Phalanx

Hi,
unter der Voraussetzung, dass die Spalten fortlaufend stehen, also keine leere Spalte dazwischen liget, sollte das so passen:

(ungetestet)

PHP-Code:
Sub getData()
Dim wb As Workbook, ws As Worksheet
Dim lng_letzte_spalte As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldr = fso.GetFolder("C:\temp\Test") 'Bitte Pfad ändern
y = ThisWorkbook.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
For Each wbFile In fldr.Files
    If fso.GetExtensionName(wbFile.Name) = "xlsx" Then
        Set wb = Workbooks.Open(wbFile.Path)
    
        For Each ws In wb.Sheets
            With ws
              lng_letzte_spalte = .Cells(1, Columns.Count).End(xlToLeft).Column
              wslr = .Cells(Rows.Count, 1).End(xlUp).Row
              .Range(.Cells(2, lng_letzte_spalte), .Cells(wslr, lng_letzte_spalte)).Copy _
                        ThisWorkbook.Sheets("sheet1").Cells(y, 1)
              y = ThisWorkbook.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
            End With
    
        Next ws
          wb.Close
    End If
Next wbFile
End Sub

Gruß Regina 

Hi Regina,

danke für deine Antwort.
Leider kopiert der Code immer nur die letzte Spalte der jeweiligen Workbooks.

Hättest du vielleicht noch eine andere Idee hierfür?

... sorry, mein Fehler:

PHP-Code:
Sub getData()
Dim wb As Workbook, ws As Worksheet
Dim lng_letzte_spalte As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldr = fso.GetFolder("C:\temp\Test") 'Bitte Pfad ändern
y = ThisWorkbook.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
For Each wbFile In fldr.Files
    If fso.GetExtensionName(wbFile.Name) = "xlsx" Then
        Set wb = Workbooks.Open(wbFile.Path)
    
        For Each ws In wb.Sheets
            With ws
              lng_letzte_spalte = .Cells(1, Columns.Count).End(xlToLeft).Column
              wslr = .Cells(Rows.Count, 1).End(xlUp).Row
              .Range(.Cells(2, 1), .Cells(wslr, lng_letzte_spalte)).Copy _
                        ThisWorkbook.Sheets("sheet1").Cells(y, 1)
              y = ThisWorkbook.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
            End With
    
        Next ws
          wb.Close
    End If
Next wbFile
End Sub 

Code:
Sub M_snb()

   c00="C:\temp\Test\"

   c01=dir(c00 & "*.xlsx")

   do until c01=""

     with getobject(c00 & c01)

        for each it in .sheets

          ThisWorkbook.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).offset(1).resize(it.usedrange.rows.count,it.usedrange.columns.count)=it.usedrange.value

        next

        .close

     end with

     c01=Dir

  Loop

End Sub

Vielen Dank!!!

... in der Annahme, dass sich das auf meinen Beitrag bezog: Danke für die Rückmeldung.

Gruß Regina

Eure beiden Codes funktionieren Wink

Also Danke an euch beide! Hätte ich mal eher hier im Forum gefragt Smile

Phalanxz1

ReginaR

Phalanxz1

ReginaR

snb

Phalanxz1

ReginaR

Phalanxz1