Hallo,
bitte eine Zelle mit folgendem Namen benennen:
LetztesDatum
Nun dann dieses Makro nutzen. Alle Dateien, deren Speicherdatum neuer als das Datum
in dieser Zelle ist, werden berücksichtigt.
Die Fehlerbehandlung am Anfang lasse ich mal auskommentiert.
Gruß
--- Makro ---
Option Explicit
Sub DatenHolen()
Dim strPfad As String
Dim strDatei As String
Dim strExt As String
Dim lngTabMax As Long
Dim lngTab As Long
Dim lngZmax As Long
Dim WB As Workbook
Dim WS As Worksheet
Dim wsAusgabe As Worksheet
'Fehlerbehandlung: ist nur das notwendigste
' On Error GoTo Aufräumen
'AusgabeTabelle anpassen
'eine neue Tabelle wird hinzugefügt
' Set wsAusgabe = ThisWorkbook.Worksheets.Add
'Fester Name
Set wsAusgabe = ThisWorkbook.Worksheets("Tabelle1")
Dim booAlleTabellen As Boolean
Dim arrBereich As Variant
Dim arrBereichIndex As Long
Dim arrDaten As Variant
Dim lngArrZmax As Long
Dim lngArrSmax As Long
Dim datLetztesDatum As Date
Dim datDatei As Date
datLetztesDatum = wsAusgabe.Range("LetztesDatum")
'Pfadname anpassen
strPfad = "C:\temp\test\"
If Right(strPfad, 1) <> "\" Then strPfad = strPfad & "\"
'Dateiendung anpassen
strExt = "*.xls*"
'Bereich der zu durchsuchenden Zellen anpassen
arrBereich = Array("G2", "B6", "B8", "B9", "H8", "M9")
'Anpassen: False = nur erste Tabelle; True = alle Tabellen
booAlleTabellen = False
If booAlleTabellen = False Then
lngTabMax = 1
Else
lngTabMax = WB.Worksheets.Count
End If
'Erste Datei suchen
strDatei = Dir(strPfad & strExt)
'Solange noch Dateien da sind
Do While Len(strDatei) > 0
'Speicherdatum holen
datDatei = FileDateTime(strPfad & strDatei)
'Datei nach letztem Datum erstellt?
If datLetztesDatum < datDatei Then
'Datei öffnen
Set WB = Workbooks.Open(Filename:=strPfad & strDatei, ReadOnly:=True)
If Not WB Is Nothing Then
'Wenn Datei offen dann alle gewünschten
'Tabellen durchgehen (eine oder alle)
For lngTab = 1 To lngTabMax
'Tabelle auswählen
Set WS = WB.Worksheets(lngTab)
'Bereich in Variable schreiben
ReDim arrDaten(UBound(arrBereich))
'alle Werte in Array schreiben
For arrBereichIndex = LBound(arrBereich) To UBound(arrBereich)
arrDaten(arrBereichIndex) = WS.Range(arrBereich(arrBereichIndex)).Value2
Next arrBereichIndex
'Zielzeile suchen
lngZmax = wsAusgabe.Cells(2 ^ 16, 1).End(xlUp).Row + 1
'Daten ausgeben
wsAusgabe.Range(wsAusgabe.Cells(lngZmax, 1), wsAusgabe.Cells(lngZmax, UBound(arrDaten) + 1)) = arrDaten
Next lngTab
'Datei schliessen
WB.Close False
End If 'Not WB is Nothing
End If 'datLetztesDatum < datDatei
'nächste Datei
strDatei = Dir()
Loop
Aufräumen:
'Notfalls Datei schliessen
On Error Resume Next
WB.Close False
On Error GoTo 0
'Aktuelles Datum speichern
wsAusgabe.Range("LetztesDatum") = Format(Now(), "dd.mm.yyyy")
'Variablen zurücksetzen
Set WS = Nothing
Set WB = Nothing
Set wsAusgabe = Nothing
End Sub
|