Die Reihenfolge der Ausführung stimmt nicht.
04.03.2024 09:06:34
Uli
ich habe folgendes Problem:
Ich hole mir mittels Access über 2 Makros Daten in eine Excel-Datei (Dateipfad ist rausgelöscht - Funktioniert aber):
Function AutoExec()
If Time > TimeValue("08:06:30") And Time = TimeValue("08:07:30") Then
Application.RunCommand acCmdAppMinimize
Call Export_Data_FH
DoCmd.Quit acSave
End If
End Functionund
Function Export_Data_FH()
On Error GoTo Export_Data_FH_Err
DoCmd.SetWarnings False
DoCmd.OpenQuery "FH_FK", acViewNormal, acEdit
DoCmd.OpenQuery "FH_F1", acViewNormal, acEdit
DoCmd.OpenQuery "F15-F1", acViewNormal, acEdit
DoCmd.TransferSpreadsheet acExport, 10, "EXTBL_FH_FK", True, "IM_FK"
DoCmd.TransferSpreadsheet acExport, 10, "EXTBL_FH_F1", True, "IM_F1"
DoCmd.TransferSpreadsheet acExport, 10, "EXTBL_FH_F15_F1", True, "IM_F15_F1"
' Erstellen Sie ein Excel-Objekt und führen Sie es im Hintergrund aus
Dim appExcel As Object
Set appExcel = CreateObject("Excel.Application")
appExcel.Visible = False
' Öffnen Sie die Arbeitsmappe und führen Sie das Makro aus
Dim wb As Object
Set wb = appExcel.Workbooks.Open("Excel-Datei")
' Schließen Sie die Arbeitsmappe und Excel
wb.Close SaveChanges:=True
appExcel.Quit
' Freigeben der Ressourcen
Set wb = Nothing
Set appExcel = Nothing
If Time > TimeValue("08:06:30") And Time = TimeValue("08:07:30") Then
DoCmd.Quit acSave
End If
Export_Data_FH_Exit:
Exit Function
Export_Data_FH_Err:
MsgBox Error$
Resume Export_Data_FH_Exit
End Function
Bis hierher funktioniert alles:
Das öffnet dann Excel und triggert weitere Makros:
Sub Workbook_open()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ActiveWorkbook.Worksheets("IM_FK").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("IM_FK").AutoFilter.Sort.SortFields.Add Key:=Range( _
"E1:E10"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("IM_FK").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("IM_FK").Select
Range("A2:E11").Select
Selection.Copy
Sheets("Access-Verknüpfung").Select
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("IM_F1").Select
Range("A2:A11").Select
Selection.Copy
Sheets("Access-Verknüpfung").Select
Range("M1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("IM_F15_F1").Select
Range("A2:C16").Select
Selection.Copy
Sheets("Access-Verknüpfung").Select
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("AWEingabe BA").Select
Range("J1:N13").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Eingabe BA").Select
Range("J1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("AWEingabe BA").Select
Range("J15:N27").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Eingabe BA").Select
Range("J15").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("AWEingabe BA").Select
Range("J30:N42").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Eingabe BA").Select
Range("J30").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("AWEingabe BA").Select
Range("A1:G51").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Eingabe BA").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Time > TimeValue("08:05:45") And Time = TimeValue("08:09:00") Then
Call Aufbereitung_PDF
End If
End Subund
Sub Aufbereitung_PDF()
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Dim saveLocation As String
Dim sheetArray As Variant
Dim j As Long, z As Long
Dim lz1 As Long
' Drucken Bereitstellliste
saveLocation = ""
sheetArray = Array("Bereitstellliste")
dateiname = "Bereitstellzeitpunkte FH_" & Range("R3") & ".pdf"
Sheets(sheetArray).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=saveLocation & dateiname
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Erstellen Backup
Sheets("AWEingabe BA").Select
Range("A1:N51").Select
Selection.Copy
Sheets("Backup").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("AWEingabe BA").Select
Range("O1:AD14").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Backup").Select
Range("O1").Select
ActiveSheet.Paste
Sheets("AWEingabe BA").Select
Application.CutCopyMode = False
Sheets("AWEingabe BA").Select
' Aufbereitung Puffer
lz1 = Cells(Rows.Count, 1).End(xlUp).Row
For j = lz1 To 2 Step -1
If Cells(j, 25) = True Then
Cells(j, 24).Resize(1, 1).Delete shift:=xlUp
End If
Next j
z = Cells(Rows.Count, 24).End(xlUp).Row + 1
lz1 = Cells(Rows.Count, 19).End(xlUp).Row
For j = 2 To lz1
If Cells(j, 19) = False Then
Cells(j, 18).Resize(1, 3).Copy Cells(z, 24)
z = z + 1
End If
Next j
Range("X2:X13").Copy
Range("X2").PasteSpecial Paste:=xlPasteValues
'Formatierung Puffer
Range("Z1").Select
Selection.Copy
Range("Y2:Y13").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("W2").Select
Selection.Copy
Range("X2:X13").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("W2").Select
Selection.Copy
Range("Y2:Y13").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'Aufbereiten BA
Range("A12:E51").Select
Application.CutCopyMode = False
Selection.Copy
Range("A2").Select
ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=False, _
IconFileName:=False
' Löschen leere Zellen
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Set ws = ThisWorkbook.Worksheets("AWEingabe BA")
Set rng = ws.Range("C32:C41")
For Each cell In rng
If cell.Value = "" Then
cell.ClearContents
End If
Next cell
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
' Speichern und Schließen
ActiveWorkbook.Close SaveChanges:=True
End Sub
Das Makro soll die Daten aus Access aufbereiten, als PDF abspeichern und die Excel-Datei für den nächsten Tag so aufbereiten, dass die Daten dann einfach nur wieder eingefügt werden müssen (eben mittels Makro). Das hat bisher eigentlich auch alles ganz gut funktioniert, bis ich die Idee hatte, dass es viel angenehmer wäre, wenn das ganze im Hintergrund funktionieren würde und ich
' Erstellen Sie ein Excel-Objekt und führen Sie es im Hintergrund aus
Dim appExcel As Object
Set appExcel = CreateObject("Excel.Application")
appExcel.Visible = False
' Öffnen Sie die Arbeitsmappe und führen Sie das Makro aus
Dim wb As Object
Set wb = appExcel.Workbooks.Open("Excel-Datei")
' Schließen Sie die Arbeitsmappe und Excel
wb.Close SaveChanges:=True
appExcel.Quit
' Freigeben der Ressourcen
Set wb = Nothing
Set appExcel = Nothing
hinzugefügt habe. Nun wird die PDF-Datei erstellt, aber der Inhalt ist leer und abschließend bekomme ich von Access eine Fehlermeldung "Get Object", die ich einfach nur Bestätigen muss und sich Access dann automatisch schließt.
Wenn ich die Excel-Datei nun manuell öffne, dann ist die Excel-Datei schon aufbereitet für das nächste mal. Daher müsste ja eigentlich alles richtig funktionieren.
Ich bin aktuell ein bisschen ratlos und würde hoffen, dass mir jemand helfen kann.
Danke und Lg Uli