AW: Zellen aus Dateien in eine Liste kopieren
03.02.2014 16:53:24
fcs
Hallo Jürgen,
hier ein Makro, das Daten aus den Exceldateien Dateien im Verzeichnnis ausliest.
Damit nicht jedes mal alle Dateien geöffnet werden müssen werden in der Liste auch der Dateiname und das Speicherdatum der Dateien gespeichert.
Die beiden Makros kopierst du im VBA-Editor in das Modul "DieseArbeitsmappe" der Datei.
Beim Öffnen der Datei wird dann automatisch gefragt, of die daten aktualisiert werden sollen.
Gruß
Franz
'Code im VBA-Editor unter DieseArbeitsmappe der Datei
Option Explicit
Sub FahrtenbuchAktualisieren()
Dim wksZ As Worksheet
Dim wkbQ As Workbook, wksQ As Worksheet
Dim rngZ As Range, ZeileZ As Long
Dim strVerzeichnis As String, varDatei, strDatei, bolRead As Boolean
Dim datDateidatum As Date
Dim StatusCalc As Long
On Error GoTo Fehler
strVerzeichnis = "Y:\Test" 'Verzeichnis mit den auszulesenden Dateien - anpassen !!!
Set wksZ = ActiveWorkbook.Worksheets("Fahrtenbuch") 'anpassen !!!
'Makrobremsen lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation 'Berechnungsmodus merken
.Calculation = xlCalculationManual
.EnableEvents = False
End With
'Exceldateien im Verzeichnis suchen
varDatei = Dir(strVerzeichnis & "\*.xls*")
Do Until varDatei = ""
bolRead = False
'Pfad + Dateiname in Variable schreiben
strDatei = strVerzeichnis & "\" & varDatei
datDateidatum = VBA.FileDateTime(strDatei) 'Speicherdatum der Datei
With wksZ
'Dateiname in Spalte A der Zieltabelle suchen
Set rngZ = .Columns(1).Find(what:=varDatei, LookIn:=xlValues, lookat:=xlWhole)
If rngZ Is Nothing Then
'Datei Neu
ZeileZ = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
bolRead = True
Else
'Datei schon vorhanden
ZeileZ = rngZ.Row
'Speicherdatum vergleichen
If datDateidatum .Cells(ZeileZ, 2) Then bolRead = True
End If
If bolRead = True Then
'Reiseabrechnungsdatei öffnen - schreibgeschützt
Set wkbQ = Application.Workbooks.Open(Filename:=strDatei, _
UpdateLinks:=False, ReadOnly:=True)
'Quelltabelle setzen
Set wksQ = wkbQ.Worksheets(1) ' oder wkbQ.Worksheets("Tabelle ABC")
'Daten in Zieltabelle eintragen
.Cells(ZeileZ, 1) = varDatei 'Dateiname
.Cells(ZeileZ, 2) = datDateidatum 'Speicherdatum
.Cells(ZeileZ, 3) = wksQ.Range("A1")
.Cells(ZeileZ, 4) = wksQ.Range("B1")
.Cells(ZeileZ, 5) = wksQ.Range("C1")
.Cells(ZeileZ, 6) = wksQ.Range("F3")
'usw.
'Quelldatei wieder schliessen
wkbQ.Close savechanges:=False
End If
End With
'nächste Datei suchen
varDatei = Dir
Loop
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
.EnableEvents = True
End With
End Sub
Private Sub Workbook_Open()
If MsgBox("Fahrtenbuch jetzt aktualisieren?", _
vbQuestion + vbOKCancel, "Fahrtenbuch") = vbOK Then
Call FahrtenbuchAktualisieren
End If
End Sub