Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

VBA / Dateien mergen für Masterdatei
#1
Wink 
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
Antwortento top
#2
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 Workbookws 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 
Antwortento top
#3
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?
Antwortento top
#4
... sorry, mein Fehler:

PHP-Code:
Sub getData()
Dim wb As Workbookws 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 
Antwortento top
#5
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
Zum übersetzen von Excel Formeln:

http://dolf.trieschnigg.nl/excel/index.p...gids=en+de
Antwortento top
#6
Vielen Dank!!!
Antwortento top
#7
... in der Annahme, dass sich das auf meinen Beitrag bezog: Danke für die Rückmeldung.

Gruß Regina
Antwortento top
#8
Eure beiden Codes funktionieren Wink Also Danke an euch beide! Hätte ich mal eher hier im Forum gefragt Smile
Antwortento top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste