An Ramses:Verzeichnis auslesen->Daten auflisten 2.
Oliver
und auch an alle anderen. Ich benötige noch mal Deine Hilfe. Die Aufgabenstellung ist ähnlich der von gestern, bei der Du mir so super geholfen hast. Ich habe ein Verzeichnis namens Testdatei. In dem Verzeichnis befinden sich mehrere Unterverzeichnisse namens Testdatei 01, Testdatei 02 usw. In den Unterverzeichnissen befinden sich Exceldateien. Nun möchte ich in Spalte A die Namen der Untervezeichnisse aufgelistet haben. In Spalte B sollen die Dateinamen von den Exceldateien, die sich in dem jeweiligen Unterverzeichnissen befinden, aufgelsitet werden. In Spalte C und D sollten Daten aus den jeweiligen Exceldateien aus dem Tabellenblatt "Vorlage" eingefügt werden. Aber nur die Werte, keine Formeln. Ich habe mal ein Bild hochgeladen, aus dem das vielleicht ersichtlich wird, was ich mir vorstelle.
Für allen anderen Helfer, kommt hier noch der Code, den Ramses gestern für mich erarbeitet hat, eventuell kann der als Grundlage genutzt werden.
Sub Daten_kopieren2()
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:H50").ClearContents
tarRow = tarWks.Cells(Rows.Count, 1).End(xlUp).Row + 3
Range("A" & tarRow & ":E" & tarRow).Select
With Selection.Interior
.ColorIndex = 36
End With
sPath = "E:\Testdatei"
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sFile = Dir(sPath & "*.xls")
Do While sFile <> ""
tarWks.Cells(tarRow, 2) = 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, 1) = qWks.Name
'liest aus sFile J4
qWks.Cells(5, 10).Copy _
Destination:=tarWks.Cells(tarRow, 2)
'liest aus sFile J5
qWks.Cells(4, 10).Copy _
Destination:=tarWks.Cells(tarRow, 3)
'liest aus sFile P2
qWks.Cells(2, 16).Copy _
Destination:=tarWks.Cells(Cells(tarRow, 4).Row, 4)
'liest aus sFile P3
qWks.Cells(3, 16).Copy _
Destination:=tarWks.Cells(Cells(tarRow, 5).Row, 5)
tarRow = tarRow + 1
Next
qWb.Close False
exit_loop:
'tarRow = tarRow + 1
Range("A" & tarRow & ":E" & tarRow).Select
With Selection.Interior
.ColorIndex = 36
End With
sFile = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Schon mal besten Dank an alle helfer,
Oliver