VBA / Dateien mergen für Masterdatei

[Phalanxz1]

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

[ReginaR]

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 


[Phalanxz1]

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?

[ReginaR]

... 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 


[snb]

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

[Phalanxz1]

Vielen Dank!!!

[ReginaR]

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

Gruß Regina

[Phalanxz1]

Eure beiden Codes funktionieren  Also Danke an euch beide! Hätte ich mal eher hier im Forum gefragt