Webabfrage - Lauzeitfehler | HERBERS Excel Forum

Private Sub Daten_aktualisieren() Application.ScreenUpdating = False Application.DisplayAlerts = False Dim Tag, Monat, Jahr, ws As Worksheet, qt As QueryTable ' Alle Links in der Arbeitsmappe aktualisieren ActiveWorkbook.RefreshAll ' Layout anpassen For Each ws In ActiveWorkbook.Worksheets ws.Cells(1, 1).HorizontalAlignment = xlLeft ws.Hyperlinks.Delete For Each qt In ActiveSheet.QueryTables qt.Delete Next Next ws ' Speicherdatum festlegen Tag = Format(Day(Mid(Sheets("ALST").Range("A1"), 19, 10)), "00") Monat = Format(Month(Mid(Sheets("ALST").Range("A1"), 19, 10)), "00") Jahr = Format(Year(Right(Sheets("ALST").Range("A1"), 4)), "0000") ' Datei Abspeichern ActiveWorkbook.SaveAs Filename:="C:\Bericht_08\Tageswerte" & Jahr & "-" & Monat & "-" & Tag _ _ & ".xls" Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Thomas,
ich hab es mal mit OnTime probiert. Alle 5 Sekunden erolgt eine Prüfung, ob noch Aktualisierungen laufen. Diese Routine wird rekursiv aufgerufen.
Bei mir hat es mit 2 Querries in 2 Tabellenblättern funktioniert.
Ein paar Zeilen sind meiner Meinung nach bei dir nicht ganz korrekt. Ich hab sie mit meinen Anpassungen markiert.
Gruß
Franz


Private Sub Daten_aktualisieren()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Alle Links in der Arbeitsmappe aktualisieren
ActiveWorkbook.RefreshAll
'Prüfen, ob noch Aktualisierungen laufen
Call RefreshPruefen
End Sub
Private Sub RefreshPruefen()
Dim ws As Worksheet, qt As QueryTable, bolRefreshed As Boolean
On Error GoTo Fehler
'Prüfen, ob noch Aktualisierungen laufen
For Each ws In ActiveWorkbook.Worksheets
bolRefreshed = True
For Each qt In ws.QueryTables
If qt.Refreshing = True Then
bolRefreshed = False
Exit For
End If
Next qt
If bolRefreshed = False Then
'Falls noch Aktualisierungen laufen, dann nach 5 Sekunden neuer Versuch
'        MsgBox "Datenaktualisierung läuft noch!" 'Nur zum Testen
Application.OnTime Now + TimeSerial(0, 0, 5), "RefreshPruefen"
Exit Sub
End If
Next ws
Call Formate_aktualisieren
GoTo Ende
Fehler:
MsgBox "Fehler: " & Err.Number & vbLf & Err.Description
Ende:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub Formate_aktualisieren()
Dim Tag, Monat, Jahr, ws As Worksheet, qt As QueryTable
On Error GoTo Fehler
' Layout anpassen
For Each ws In ActiveWorkbook.Worksheets
ws.Cells(1, 1).HorizontalAlignment = xlLeft
ws.Hyperlinks.Delete
'        For Each qt In Activesheet.QueryTables '##########?
For Each qt In ws.QueryTables '##########?
qt.Delete
Next
Next ws
' Speicherdatum festlegen
Tag = Format(Day(Mid(Sheets("ALST").Range("A1"), 19, 10)), "00")
Monat = Format(Month(Mid(Sheets("ALST").Range("A1"), 19, 10)), "00")
'Jahr = Format(Year(Right(Sheets("ALST").Range("A1"), 4)), "0000") '#########?
Jahr = Right(Sheets("ALST").Range("A1"), 4) '#########?
' Datei Abspeichern
ActiveWorkbook.SaveAs Filename:="C:\Bericht_08\Tageswerte" & Jahr & "-" & Monat & "-" _
& Tag & ".xls"
GoTo Ende
Fehler:
MsgBox "Fehler: " & Err.Number & vbLf & Err.Description
Ende:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Beliebteste Forumthreads (12 Monate)

Webabfrage - Lauzeitfehler

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread