Verzeichnis auslesen -> Daten auflisten!

Hi an alle,
ich dreh mich mal wieder im Kreis. Ich möchte folgendes bewerkstelligen: In einem Ordner befinden sich mehrere Exceldateien. Ich möchte nun aus jeder Datei den Inhalt aus Zelle A2, B2, C2 und den Tabellenblattname in eine andere Datei kopieren. Allerdings besteht jede Datei aus mehreren Tabellenblätter, deren Zelleninhalt von A2, B2, C2 und Tabellenblattname ebenfalls kopiert werden sollen. Die Anzahl der Tabellenblätter in den Dateien ist aber unterschiedlich. Also, es können mal 2 oder 4 usw. sein. Ich habe mir ein Makro hingebastelt, welches mir die Dateien aus dem Ordner auflistet und hinter dem Namen entsprechend den Tabellenblattnamen des 1.Tabellenblatts und dahinter die Werte aus den Zellen. Nur weiß ich jetzt nicht, wie ich die anderen Tabellenblätter einer Datei automatisch auslese und die Werte jeweils eine Zeile tiefer in der anderen Datei einfüge. Nachfolgend mal das Makro, wie ich es im Moment aussieht.


Sub Daten_kopieren()
Dim sFile As String, sPath As String
Application.ScreenUpdating = False
Range("A2:D50").ClearContents
sPath = "D:\Scheckelhoff\Daten Günther\HDF"
If Right(sPath, 1) <> "/" Then sPath = sPath & "\"
sFile = Dir(sPath & "*.xls")
Do While sFile <> ""
zeilennr = Range("A65536").End(xlUp).Row + 1
Cells(zeilennr, 1) = sFile
sFile = Dir()
Loop
Pfad = "D:\Scheckelhoff\Daten Günther\HDF\"
Anzahl = Range("A1") + 1
For i = 2 To Anzahl
Datei = Cells(i, 1).Value
Workbooks.Open Pfad & Datei
Workbooks("Inhalt.xls").Sheets("Tabelle1").Cells(i, 2) = ActiveSheet.Name
Cells(2, 1).Copy Workbooks("Inhalt.xls").Sheets("Tabelle1").Cells(i, 3)
Cells(2, 2).Copy Workbooks("Inhalt.xls").Sheets("Tabelle1").Cells(i, 4)
Cells(2, 3).Copy Workbooks("Inhalt.xls").Sheets("Tabelle1").Cells(i, 5)
ActiveWindow.Close
Next i
Application.ScreenUpdating = True
End Sub

Ich hoffe, jemand ersteht was ich vorhabe. Wenn es noch Unklarheiten geben sollte, bitte melden, damit ich diese beantworten kann.
Danke Euch schon mal im Voraus,
Oliver

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub Daten_kopieren() Dim sFile As String, sPath As String Application.ScreenUpdating = False Range("A2:D50").ClearContents sPath = "D:\Scheckelhoff\Daten Günther\HDF" If Right(sPath, 1) <> "/" Then sPath = sPath & "\" sFile = Dir(sPath & "*.xls") Do While sFile <> "" zeilennr = Range("A65536").End(xlUp).Row + 1 Cells(zeilennr, 1) = sFile sFile = Dir() z=1 Loop Pfad = "D:\Scheckelhoff\Daten Günther\HDF\" Anzahl = Range("A1") + 1 For i = 2 To Anzahl z=z+1 Datei = Cells(i, 1).Value Workbooks.Open Pfad & Datei Workbooks("Inhalt.xls").Sheets("Tabelle1").Cells(z, 2) = ActiveSheet.Name Cells(2, 1).Copy Workbooks("Inhalt.xls").Sheets("Tabelle1").Cells(z, 3) Cells(2, 2).Copy Workbooks("Inhalt.xls").Sheets("Tabelle1").Cells(z, 4) Cells(2, 3).Copy Workbooks("Inhalt.xls").Sheets("Tabelle1").Cells(z, 5) ActiveWindow.Close Next i Application.ScreenUpdating = True End Sub

Sub Daten_kopieren() Dim sFile As String, sPath As String Dim qWb As Workbook, qWks As Worksheet, tarWks As Worksheet Set tarWks = Workbooks("Inhalt.xls").Sheets("Tabelle1") Application.ScreenUpdating = False Range("A2:D50").ClearContents sPath = "D:\Scheckelhoff\Daten Günther\HDF" If Right(sPath, 1) <> "/" Then sPath = sPath & "\" sFile = Dir(sPath & "*.xls") Do While sFile <> "" sFile = Dir() tarWks.Cells(Rows.Count, 1).End(xlUp).Row 1 = sFile For i = 2 To Anzahl Workbooks.Open "" & sPfad & sFile & "" Set qWb = ActiveWorkbook For Each qWks In qWb tarWks.Cells(i, 2) = qWks.Name qWks.Cells(2, 1).Copy _ Destination:=tarWks.Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 3) qWks.Cells(2, 2).Copy _ Destination:=tarWks.Cells(Cells(Rows.Count, 1).End(xlUp).Row, 4) qWks.Cells(2, 3).Copy _ Destination:=tarWks.Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5) Next Next i Loop Application.ScreenUpdating = True End Sub

Sub Daten_kopieren() Dim sFile As String, sPath As String Dim qWb As Workbook, qWks As Worksheet, tarWks As Worksheet Dim i As Integer, Anzahl As Integer Set tarWks = Workbooks("Inhalt.xls").Sheets("Tabelle1") Application.ScreenUpdating = False Range("A2:D50").ClearContents sPath = "C:\" '"D:\Scheckelhoff\Daten Günther\HDF" If Right(sPath, 1) <> "\" Then sPath = sPath & "\" Debug.Print Dir(sPath & "*.xls") Do While Dir(sPath & "*.xls") <> "" sFile = Dir(sPath & "*.xls") tarWks.Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = sFile For i = 2 To 5 Workbooks.Open "" & sPath & sFile & "" Set qWb = ActiveWorkbook For Each qWks In qWb.Worksheets tarWks.Cells(i, 2) = qWks.Name qWks.Cells(2, 1).Copy _ Destination:=tarWks.Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 3) qWks.Cells(2, 2).Copy _ Destination:=tarWks.Cells(Cells(Rows.Count, 1).End(xlUp).Row, 4) qWks.Cells(2, 3).Copy _ Destination:=tarWks.Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5) Next qWb.Close False Next i Loop Application.ScreenUpdating = True End Sub

Sub Daten_kopieren() Dim sFile As String, sPath As String Dim qWb As Workbook, qWks As Worksheet, tarWks As Worksheet Dim i As Integer, tarRow As Integer Set tarWks = Workbooks("Inhalt.xls").Worksheets("Tabelle1") Application.ScreenUpdating = False Range("A2:D50").ClearContents sPath = "D:\Scheckelhoff\Daten Günther\HDF" If Right(sPath, 1) <> "\" Then sPath = sPath & "\" sFile = Dir(sPath & "*.xls") Do While sFile <> "" tarRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 tarWks.Cells(tarRow, 1) = sFile Workbooks.Open sPath & sFile Set qWb = ActiveWorkbook For Each qWks In qWb.Worksheets tarWks.Cells(tarRow, 2) = qWks.Name qWks.Cells(tarRow, 1).Copy _ Destination:=tarWks.Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 3) qWks.Cells(tarRow, 2).Copy _ Destination:=tarWks.Cells(Cells(Rows.Count, 1).End(xlUp).Row, 4) qWks.Cells(tarRow, 3).Copy _ Destination:=tarWks.Cells(Cells(Rows.Count, 1).End(xlUp).Row, 5) Next qWb.Close False sFile = Dir() Loop Application.ScreenUpdating = True End Sub

Moin Ramses,
sorry, dass ich mich erst heute morgen melde. Danke Dir für Deine Bemühungen mir zu helfen. Es ist mir schon fast peinlich, aber dass ist noch nicht so, wie ich es mir vorgestellt habe. Dein Makro ließt das Verzeichnis aus und listet mir die Dateinamen untereinander auf. Das ist OK. Dann wird scheinbar jede Datei geöffnet und dort soll von jeder Datei die Tabellenblätter ermittelt werden und deren Namen sollen untereinander aufgeführt werden. In Deinem Makro wird aber immer nur ein Tabellenblattname ausgelesen und in eine Zelle geschrieben. Dann sollen festgelegte Zelleninhalte aus jedem Tabellenblatt hinter den jeweiligen Tabellenblattnamen kopiert werden. Das funktionierte in meinem alten Makro schon. In dem neuen werden gar keine Zelleninhalte mehr ausgelesen und kopiert. Ich habe mal ein Screenshot hochgeladen (Hätte auch gerne die Datei hochgeladen, funktionierte aber komischerweise nicht und es wurde nur das Bild akzeptiert), aus der vielleicht etwas ersichtlicher wird, was ich mir vorstelle.
Userbild

Wenn Du so nett wärst und Dir das mal anschauen würdest und mir dann noch mal helfen würdest, das in die Tat umzusetzen? Wäre super.
Danke Dir,
Oliver

Sub Daten_kopieren() Dim sFile As String, sPath As String Dim qWb As Workbook, qWks As Worksheet, tarWks As Worksheet Dim i As Integer, tarRow As Integer Set tarWks = Workbooks("Inhalt.xls").Worksheets("Tabelle1") tarRow = tarWks.Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False Range("A2:D50").ClearContents sPath = "C:\" '"D:\Scheckelhoff\Daten Günther\HDF" If Right(sPath, 1) <> "\" Then sPath = sPath & "\" sFile = Dir(sPath & "*.xls") Do While sFile <> "" tarWks.Cells(tarRow, 1) = sFile tarRow = tarRow + 1 If sFile <> ThisWorkbook.Name Then Workbooks.Open sPath & sFile Else GoTo exit_loop End If Set qWb = ActiveWorkbook For Each qWks In qWb.Worksheets tarWks.Cells(tarRow, 2) = qWks.Name 'liest aus sFile A2 qWks.Cells(2, 1).Copy _ Destination:=tarWks.Cells(tarRow, 3) 'liest aus sFile B2 qWks.Cells(2, 2).Copy _ Destination:=tarWks.Cells(tarRow, 4) 'liest aus sFile C2 qWks.Cells(2, 3).Copy _ Destination:=tarWks.Cells(Cells(tarRow, 5).Row, 5) tarRow = tarRow + 1 Next qWb.Close False exit_loop: sFile = Dir() Loop Application.ScreenUpdating = True End Sub

Sub Daten_kopieren() Dim sFile As String, sPath As String Dim qWb As Workbook, qWks As Worksheet, tarWks As Worksheet Dim i As Integer, tarRow As Integer Set tarWks = Workbooks("Inhalt.xls").Worksheets("Tabelle1") tarRow = tarWks.Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False Range("A2:D50").ClearContents sPath = "C:\" '"D:\Scheckelhoff\Daten Günther\HDF" If Right(sPath, 1) <> "\" Then sPath = sPath & "\" sFile = Dir(sPath & "*.xls") Do While sFile <> "" tarWks.Cells(tarRow, 1) = sFile tarRow = tarRow + 1 If sFile <> ThisWorkbook.Name Then Workbooks.Open sPath & sFile Else GoTo exit_loop End If Set qWb = ActiveWorkbook For Each qWks In qWb.Worksheets tarWks.Cells(tarRow, 2) = qWks.Name 'liest aus sFile A2 qWks.Cells(2, 1).Copy _ Destination:=tarWks.Cells(tarRow, 3) 'liest aus sFile B2 qWks.Cells(2, 2).Copy _ Destination:=tarWks.Cells(tarRow, 4) 'liest aus sFile C2 qWks.Cells(2, 3).Copy _ Destination:=tarWks.Cells(Cells(tarRow, 5).Row, 5) tarRow = tarRow + 1 Next qWb.Close False exit_loop: 'Das erzeugt die zusätzliche Leerzeile tarRow = tarRow + 1 sFile = Dir() Loop Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

Verzeichnis auslesen -> Daten auflisten!

21 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

21
Beiträge zum Forumthread

Beiträge zu diesem Forumthread