VBA Makro per Klick lässt Excel freezen
14.07.2023 11:18:28
Hantelheber
ich verzweifele momentan an einem kuriosen Phänomen und hoffe, dass mir jemand helfen kann.
Über ein zusammengebasteltes Makro kopiere ich aus einer .xlsm ein Tabellenblatt in eine neue Datei und versende diese an eine Empfängerliste per Outlook.
Die Mailempfänger stehen in einem separaten Tabellenblatt.
Das klappt seit vielen Monaten ganz toll, seit möglicherweise einem Office Update, friert Excel beim Aufruf des Makros per Klick auf den Button ein.
Wenn ich das Makro im Editor starte, oder Schrittweise debugge, klappt alles einwandfrei.
Nur durch den Klick auf den Button, hängt sich alles auf :-(
Es scheint so, als ob das Makro bis zu einem bestimmten Punkt abgearbeitet wird (Sheet wird in die neue Datei kopiert und diese gespeichert), beim Aufruf der Outlook Prozedur dann jedoch alles hängen bleibt.
Auffällig ist ebenfalls, dass das Problem nur per Office 365 auftritt; mit Office 2016 läuft weiterhin alles tadellos.
Hat evtl. schon jemand eine Idee?
Herzlichen Dank vorab und viele Grüße
Holger
Anbei der Code:
Public Sub sendDiff_asXLSX()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim olApp As Object
Dim AWS As String
Dim olOldBody As String
Dim strAddress As String
Dim i As Integer
Dim strSAPDATUM As String
strSAPDATUM = ActiveWorkbook.Worksheets("VAR").Cells(37, 2).Value
Rem Pfad für PDF festlegen
AWS = Environ("USERPROFILE") & "\AppData\Local\Temp\Bestandsabgleich und Differenzen zum " & strSAPDATUM & ".xlsx"
Rem Empfängerliste zusammenstellen
For i = 1 To ThisWorkbook.Sheets("VAR_EMail").Range("A" & Rows.Count).End(xlUp).Row
If strAddress = "" Then
strAddress = ThisWorkbook.Sheets("VAR_EMail").Cells(i, 1)
Else
strAddress = strAddress & ";" & ThisWorkbook.Sheets("VAR_EMail").Cells(i, 1)
End If
Next i
Rem Tabelle als XLSX speichern
Sheets("Diff").Select
ActiveSheet.PivotTables("PVT_Differenzen").PivotCache.Refresh
Sheets(Array("Diff")).Copy
With ActiveWorkbook
.SaveAs Filename:=AWS, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close
End With
Rem Email erstellen
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.GetInspector.Display
.To = strAddress
.Subject = "Bestandsabgleich und Differenzen zum " & strSAPDATUM ' Betreff
.htmlBody = "" & _
"Hallo zusammen,
" & _
"anbei die Abweichungen zum " & strSAPDATUM & ".
"
.Attachments.Add AWS 'Datei anhängen
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub