Hallo zusammen,
ich möchte gerne alle Dateiinhalte untereinander ausgelesen bekommen, jedoch
erhalte ich nur den Inhalt der zuletzt ausgelesenen Datei. Ich bitte um Hilfe!
Desweiteren möchte ich gerne einen abgesteckten Bereich A2:A10 aus der zu
durchsuchenden Datei in eine Zeile in der Zieldatei "Auswertung" kopieren.
Vielen Dank für eure Tipps im Voraus! (P.S. Das Script ist von Oliver)
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:\Users\Philipp\Desktop\NEW\Convertiert")
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) = ".csv" 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 = KundenNummer
wksAuswertsheet.Cells(lngFirstFreeRow, 2) =
Workbooks(objDatei.Name).Sheets(1).Range("H2")
'Wert aus geöffneter Datei aus dem Tabellenblatt 1 aus Zelle _
D20 in die erste freie Zelle in Spalte A übertragen = BelegDatum
wksAuswertsheet.Cells(lngFirstFreeRow, 3) =
Workbooks(objDatei.Name).Sheets(1).Range("H4")
'Wert aus geöffneter Datei aus dem Tabellenblatt 1 aus Zelle _
D20 in die erste freie Zelle in Spalte A übertragen = LieferDatum
wksAuswertsheet.Cells(lngFirstFreeRow, 4) =
Workbooks(objDatei.Name).Sheets(1).Range("H5")
'Wert aus geöffneter Datei aus dem Tabellenblatt 1 aus Zelle _
D20 in die erste freie Zelle in Spalte A übertragen = AnsprechPartner
wksAuswertsheet.Cells(lngFirstFreeRow, 5) =
Workbooks(objDatei.Name).Sheets(1).Range("H5")
'Wert aus geöffneter Datei aus dem Tabellenblatt 1 aus Zelle _
D20 in die erste freie Zelle in Spalte A übertragen = RechnungsNr
wksAuswertsheet.Cells(lngFirstFreeRow, 6) =
Workbooks(objDatei.Name).Sheets(1).Name
'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
Besten Gruß
Philipp S.
