Hallo Bigo!
Nachfolgender VBA-Code sollte das machen, was Du Dir vorstellst.
Kopiere das Makro in ein StandardModul und starte es z.B. über eine Befehlsschaltfläche
Teste das Makro aber bitte in einer Testdatei und nicht gleich in Deiner Originaldatei.
Option Explicit
Dim objFileSystemObject As Object
Dim objDateien As Object
Dim objWeitereDateien As Object
Dim objDatei As Object
Dim lngFirstFreeRow As Long
Dim wksAuswertsheet As Worksheet
'###########################################################################################
Sub Auswertung_start()
'Objektverweise zuweisen
Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set objDateien = objFileSystemObject.getfolder("C:\Test")
Set wksAuswertsheet = ThisWorkbook.Sheets("Auswertung")
Call Dateien_auswerten
'Zuweisung wieder aufheben
Set objFileSystemObject = Nothing
Set objDateien = Nothing
Set wksAuswertsheet = Nothing
'Text aus Statusbar löschen
Application.StatusBar = ""
End Sub
'###########################################################################################
Sub Dateien_auswerten()
Application.ScreenUpdating = False
For Each objDatei In objDateien.Files
If Right(objDatei.Name, 4) = ".xls" Or Right(objDatei.Name, 5) = ".xlsx" _
Or Right(objDatei.Name, 5) = ".xlsm" Then
'erste freie Zelle in der Zieldatei in Spalte A ermitteln
lngFirstFreeRow = wksAuswertsheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'Meldung in Statusbar anzeigen
Application.StatusBar = "Datei """ & objDatei.Name & """ wird ausgelesen!"
DoEvents
'Gefundene Datei unsichtbar öffnen
GetObject (objDatei)
'Wert aus geöffneter Datei aus dem Tabellenblatt 1 aus Zelle _
D20 in die erste freie Zelle in Spalte A übertragen
wksAuswertsheet.Cells(lngFirstFreeRow, 1) = _
Workbooks(objDatei.Name).Sheets(1).Range("D10")
'Wert aus geöffneter Datei aus dem Tabellenblatt 1 aus Zelle _
D20 in die erste freie Zelle in Spalte A übertragen
wksAuswertsheet.Cells(lngFirstFreeRow, 2) = _
Workbooks(objDatei.Name).Sheets(1).Range("D20")
'Wert aus geöffneter Datei aus dem Tabellenblatt 1 aus Zelle _
D20 in die erste freie Zelle in Spalte A übertragen
wksAuswertsheet.Cells(lngFirstFreeRow, 3) = _
Workbooks(objDatei.Name).Sheets(1).Range("F28 ")
'Geöffnete Datei wieder schließen ohne zu speichern
Workbooks(objDatei.Name).Close SaveChanges:=False
End If
Next
'Nächstes Verzeichnis abfragen
For Each objWeitereDateien In objDateien.subfolders
Set objDateien = objWeitereDateien
Call Dateien_auswerten
Next
End Sub
'###########################################################################################
Das Makro liest Dir alle Dateien in einem Hauptverzeichnis und die darin befindlichen Unterverzeichnisse aus. Es werden nur Dateien mit der Endung „xls“, „xlsx“ und „xlsm“ ausgelesen und die Werte aus den Zellen D10, D20 und F28 in die erste freie Zeile in den Spalten A, B und C übertragen.
Du musst allerdings in dem Code noch ein paar Dinge anpassen. Zunächst den Hauptpfad, in dem sich dann die ganzen Unterverzeichnisse befinden. Dazu ändere in der Zeile
Set objDateien = objFileSystemObject.getfolder("C:\Test")
den Pfad “C:\Test” gegen Deinen Pfad aus. Aber Achtung, der Pfad gehört zwischen die beiden Anführungsstriche. Außerdem musst Du die Blattindexzahl ändern, wenn die Daten nicht im 1. Tabellenblatt der auszulesenden Datei stehen. Dazu in dem VBA-Code in den Zeilen, in denen
Workbooks(objDatei.Name).Sheets(1).Range(……
steht die Zahl bei Sheets(1) gegen die Zahl des auszulesenden Tabellenblatts ändern.
Solltest Du nicht wissen, wie Du den Code in Deine Datei bekommst, dann schau mal auf
meiner HP in der
Rubrik Anleitungen und dort dann in der
Anleitungsnummer 3 nach. Dort stelle ich dazu eine bebilderte Anleitung zur Verfügung, die Dir sicherlich helfen wird.
Bei Fragen melde Dich.
MfG,
Oliver
[sup]Jeder macht was er will, keiner macht was er soll, aber alle machen mit.[/sup]