AW: Bei speichern Tabellenblatt aus anderer Datei
28.05.2013 13:52:52
UweD
Hallo nochmal
Hier eine Fehlerbereinigte Version
Option Explicit
Private NextTime As Double
Sub AutoUpdate()
On Error GoTo Fehler
Dim WB1, WB2, TB1, TB2, i%
Dim Datumformat$, LogTab
Dim Pfad$, Datei$, Pre$
Dim NextInst
Set WB1 = ActiveWorkbook
Set TB1 = ActiveSheet
' *****anpassen!!!
LogTab = "LOG"
Datumformat = "DD.MM.YYYY"
Pfad = "C:\Temp\"
Datei = "Datei2.xlsx"
Pre = "ABC " ' evt. vorangestellter Zusatz der Tabellennamen
Application.ScreenUpdating = False
For i = 1 To WB1.Sheets.Count ' prüfen, ob aktueller Tag schon da
If WB1.Sheets(i).Name = Pre & Format(Date, Datumformat) Then 'löschen, wenn schon da
Application.DisplayAlerts = False
WB1.Sheets(i).Delete
Application.DisplayAlerts = True
Exit For
End If
Next
Workbooks.Open Filename:=Pfad & Datei
Set WB2 = ActiveWorkbook
For i = 1 To WB2.Sheets.Count
If WB2.Sheets(i).Name = Pre & Format(Date, Datumformat) Then
WB2.Sheets(i).Copy After:=WB1.Sheets(WB1.Sheets.Count)
WB1.Sheets(LogTab).Activate
ActiveSheet.Range("A1") = "Letztes Update: " & Format(Now, "DD.MM.YYYY hh:mm:ss")
Exit For
End If
Next
Workbooks(Datei).Close SaveChanges:=False
'Wiederholung starten
StartAutoUpdate
Err.Clear
Fehler:
If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
Application.DisplayAlerts = True
End Sub
Sub StartAutoUpdate()
'NextTime = Now + TimeSerial(0, 5, 0) '5 min
NextTime = Now + TimeSerial(0, 0, 20) 'zum Testen 20 Sekunden
Application.OnTime NextTime, "AutoUpdate"
End Sub
Sub StoppAutoUpdate()
On Error Resume Next
Application.OnTime NextTime, "AutoUpdate", Schedule:=False
End Sub
Gruß UweD