|
Hallo,
ich teste gerade erstmals die Ausführung eines Excel-Makros durch Aufruf einer VBS-Datei und lauf dabei auf dem im Thema beschriebenen Fehler.
Hier die VBS-Datei:
' Referenz: https://www.youtube.com/watch?v=mNvFCE1pjAM
' Excel starten
Set xlsApp = CreateObject("Excel.Application")
'Sichtbarkeit
'xlsApp.Visible = False
xlsApp.Application.Visible = False
'Workbook öffnen
Set xlsWb = xlsApp.Workbooks.Open("C:\Users\Wilfried\Documents\Excel\Power Queries remote aktualisieren - Test_1.xlsm")
'Makro ausführen
xlsApp.Run("Aufgabenplanung")
xlsApp.DisplayAlerts = False
xlsApp.ActiveWorkbook.Close True
'Workbook close
xlsApp.Quit
Und hier der MakroCode:
Option Explicit
Sub Aufgabenplanung()
Call Remote_Refresh
' MsgBox "Remote_refresh: finished"
' Bei einem Aufruf durch eine VBS-Datei erzeugen die Nachfolgenden Schritte Fehlermeldungen.
' Wobei das sichern auch aus dem VBS-Script durchgeführt werden kann
' ActiveWorkbook.Connections("Abfrage - tbl_Log_Queries").Refresh
' MsgBox "Abfrage - tbl_Log_Queries: finished"
' ActiveWorkbook.Connections("Abfrage - tbl_Log_Workbooks").Refresh
' MsgBox "Abfrage - tbl_Log_Workbooks: finished"
' ActiveWorkbook.Save
' MsgBox "ActiveWorkbook.Save: finished"
End Sub
Sub Remote_Refresh()
Dim wb As Workbook, _
WB_name As String, _
wb_remote As String, _
no_close As String, _
curr_WB_name As String, _
excel_File As Workbook, _
wk_path_wb As String, _
wk_repeats As Integer, _
wk_count As Integer, wk_refreshes As Integer, _
idx As Integer, _
x As Integer, _
Last_Dir As String, Last_WB As String, Curr_Dir As String, Curr_WB As String, _
wb_opened As String, _
wk_now
Dim PQ_start As Double, _
PQ_Ende As Double, _
PQ_Dauer As Double, _
wk_range As String, _
PQ_name As String, PQ_name_pur As String, _
lobj_log As ListObject, _
log_rows As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
wk_count = Sheets("T1").ListObjects("tbl_remote_refresh").ListRows.Count
log_rows = Sheets("Log").ListObjects("tbl_Log").ListRows.Count
wk_now = DateTime.Now
WB_name = ActiveWorkbook.Name
For idx = 1 To wk_count
With Sheets("T1").ListObjects("tbl_remote_refresh")
If idx = 1 Then
.ListColumns("Start").DataBodyRange.ClearContents
.ListColumns("Ende").DataBodyRange.ClearContents
.ListColumns("Dauer").DataBodyRange.ClearContents
End If
If .ListColumns("Directory").DataBodyRange(idx).Value <> "" Then
Curr_Dir = .ListColumns("Directory").DataBodyRange(idx).Value
End If
If .ListColumns("Workbook").DataBodyRange(idx).Value <> "" Then
Curr_WB = .ListColumns("Workbook").DataBodyRange(idx).Value
End If
If Curr_Dir = "" Then
Curr_Dir = Last_Dir
End If
If Curr_WB = "" Then
Curr_WB = Last_WB
End If
If (Curr_Dir <> Last_Dir Or _
Curr_WB <> Last_WB) And _
wb_opened = "x" Then
wb_opened = ""
Last_Dir = Curr_Dir
Last_WB = Curr_WB
If wk_refreshes > 0 Then
wk_refreshes = 0
If no_close <> "x" Then
wb.Windows(1).Visible = True
wb.Close SaveChanges:=True
Else
wb.Save
End If
Else
If no_close <> "x" Then
wb.Close SaveChanges:=False
End If
End If
End If
Last_Dir = Curr_Dir
Last_WB = Curr_WB
If Curr_Dir <> "" And Curr_WB <> "" And wb_opened = "" Then
For Each excel_File In Workbooks
If excel_File.Name = Curr_WB Then
no_close = "x"
Exit For
End If
Next
wb_remote = Curr_Dir & Curr_WB
On Error GoTo not_opened
Application.DisplayAlerts = False
Set wb = GetObject(wb_remote) 'Auch notwendig, wenn bereits offen
Application.DisplayAlerts = True
wb_opened = "x"
On Error GoTo 0
End If
' Nur wenn ein Workbook geöffnet wurde, wird Refresh = "Ja" berücksichtigt
' In den Abfrageeinstellungen der relevanten Abfragen muss die Option
' "Aktualisierung im Hintergrund zulassen" deaktiviert sein.
If .ListColumns("Refresh").DataBodyRange(idx).Value = "Ja" And wb_opened = "x" Then
wk_refreshes = wk_refreshes + 1
PQ_name = "Abfrage - " & .ListColumns("Query").DataBodyRange(idx).Value
PQ_name_pur = .ListColumns("Query").DataBodyRange(idx).Value
PQ_start = Timer
wb.Connections(PQ_name).Refresh
PQ_Ende = Timer
PQ_Dauer = PQ_Ende - PQ_start
.ListColumns("Start").DataBodyRange(idx).Value = PQ_start / 86400
.ListColumns("Ende").DataBodyRange(idx).Value = PQ_Ende / 86400
.ListColumns("Dauer").DataBodyRange(idx).Value = PQ_Dauer
.ListColumns("Anz. Dauer").DataBodyRange(idx).Value = .ListColumns("Anz. Dauer").DataBodyRange(idx) + 1
.ListColumns("Dauer kum.").DataBodyRange(idx).Value = .ListColumns("Dauer kum.").DataBodyRange(idx) + PQ_Dauer
If .ListColumns("Dauer min.").DataBodyRange(idx).Value = "" Or _
.ListColumns("Dauer min.").DataBodyRange(idx).Value > PQ_Dauer Then
.ListColumns("Dauer min.").DataBodyRange(idx).Value = PQ_Dauer
End If
If .ListColumns("Dauer max.").DataBodyRange(idx).Value = "" Or _
.ListColumns("Dauer max.").DataBodyRange(idx).Value < PQ_Dauer Then
.ListColumns("Dauer max.").DataBodyRange(idx).Value = PQ_Dauer
End If
End If
If .ListColumns("Refresh").DataBodyRange(idx).Value = "Ja" And wb_opened = "x" Then
With Sheets("Log").ListObjects("tbl_Log")
.ListRows.Add
log_rows = log_rows + 1
.ListColumns("Timestamp").DataBodyRange(log_rows).Value = wk_now
.ListColumns("Workbook").DataBodyRange(log_rows).Value = Curr_WB
.ListColumns("Query").DataBodyRange(log_rows).Value = PQ_name_pur
.ListColumns("Start").DataBodyRange(log_rows).Value = PQ_start / 86400
.ListColumns("End").DataBodyRange(log_rows).Value = PQ_Ende / 86400
.ListColumns("Duration").DataBodyRange(log_rows).Value = PQ_Dauer
End With
End If
End With
not_opened:
Application.DisplayAlerts = True
Next
If wk_refreshes > 0 Then
If no_close <> "x" Then
wb.Windows(1).Visible = True
wb.Close SaveChanges:=True
Else
' Werden die Änderungen in der geöffneten Mappe gezeigt ???
wb.Save
End If
Else
If no_close <> "x" Then
wb.Close SaveChanges:=False
End If
End If
' On Error Resume Next
' Bei einem Aufruf durch eine VBS-Datei erzeugt der nachfolgende Schritt eine Fehlermeldung.
Application.Calculation = xlCalculationAutomatic
' On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Die Fehlermeldung wird durch die rot markierte Zeile verursacht. Jedoch nicht, wenn das Makro direkt aus der Mappe aufgerufen wird.
Vielleicht hat ja jemand eine Erklärung für dieses Verhalten.
Ich arbeite mit Win 11 und Office 365.
|