Hallo zusammen,

so ganz firm bin ich nicht in VBA, aber mit Schnipseln zusammen suchen komme ich meistens ans Ziel.

Ich habe hier einen Code, der ein Excel-Tabellenblatt kopieren, nur die Werte einfügen soll, versteckte Zeilen/Spalten sollen gelöscht werden und anschließend soll das neue Excel-Sheet per Email versendet werden.

Die Ausführung dieses Codes dauert recht lange (ca. 1 Min.). Hat jemand eine Idee, wie ich den Code verbessern kann, damit die Ausführung schneller geht?

Hier der Code:

Sub Excel_Sheet_via_Outlook_Senden()

'**Optimierung der VBA-Geschwindigkeit
    ' Save the current state of Excel settings.
    screenUpdateState = Application.ScreenUpdating
    statusBarState = Application.DisplayStatusBar
    calcState = Application.Calculation
    eventsState = Application.EnableEvents
    ' Note: this is a sheet-level setting.
    displayPageBreakState = ActiveSheet.DisplayPageBreaks

    ' Turn off Excel functionality to improve performance.
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ' Note: this is a sheet-level setting.
    ActiveSheet.DisplayPageBreaks = False
      
    'Variablendefinition
    Dim MyMessage As Object, MyOutApp As Object
    Dim SavePath As String
    Dim AWS As String
    Dim strFile As String

    'Speichervariablen festlegen
    SavePath = "C:\Eigene Dateien"
    'strFile = "Aktuelles Angebot KW" & Range("B17").Value & "_2022" & ".xlsx"
    strFile = "Aktuelles Angebot " & Range("B17").Value & ".xlsx"
    
    
    'Kopiert aktuelles Sheet in eine neue Mappe
    'welche nur diese Tabelle enthält
    ActiveSheet.Copy
      
    'Tabelle kopieren und als Werte einfügen
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    'ausgeblendete Zeilen/Spalten löschen
    Call Ausgeblendetloeschen
       
    'Spalten K-Z löschen
    Columns("K:Z").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Delete Shift:=xlToLeft
    Range("L6").Select
    
    'Speichert die Datei unter dem Tabellennamen und einem Zeitstempel
    ActiveWorkbook.SaveAs SavePath & strFile
    
    'Mappenname wird an Variable übergeben
    'und anschliessend gleich geschlossen
    With ActiveWorkbook
        AWS = .FullName
        .Close
    End With
    
    'InitializeOutlook = True
    Set MyOutApp = CreateObject("Outlook.Application")
    
    'Nachrichtenobject erstellen
    Set MyMessage = MyOutApp.CreateItem(0)
    With MyMessage
    .To = CStr(Range("C14")) 'Empfänger
    .bcc = CStr(Range("P6"))    'Blindkopie-Empfänger
    '.Subject = "Aktuelles Angebot KW" & Range("B17")  'Betreffzeile
    .Subject = "Aktuelles Angebot " & Range("B17")  'Betreffzeile
          
        'Hier wird die temporär gespeicherte Datei als
        'Attachment zugefügt
        .Attachments.Add AWS
        'Hier wird eine normale Text Mail erstellt
        .body = "Sehr geehrte Damen und Herren," & vbCrLf & vbCrLf & Range("O8") & vbCrLf & Range("O9") & vbCrLf & Range("O10") & vbCrLf & Range("O11") & vbCrLf
        'Hier wird die HTML Mail erstellt
        '.HTMLBody = "Sehr geehrte Damen und Herren," & vbCrLf & vbCrLf & "als Anlage erhalten Sie unser aktuelles Angebot." & vbCrLf & vbCrLf & "Über einen Auftrag würden wir uns freuen." & vbCrLf
        'Hier wird die Mail nochmals angezeigt
        .Display
        'Hier wird die Mail gleich in den Postausgang gelegt
        '.Send
        'Hier wird die temporäre Datei wieder gelöscht
        Kill AWS
    End With
    
    'Hier wird Outlook direkt wieder verlassen
    'MyOutApp.Quit
    
    '** Objektvariablen wieder löschen
    'Set MyOutApp = Nothing
    'Set MyMessage = Nothing
    'Set SavePath = Nothing
    'Set strFile = Nothing
    
'**nach VBA-Ausführung Excel-Zustand wiederherstellen
    ' Restore Excel settings to original state.
    Application.ScreenUpdating = screenUpdateState
    Application.DisplayStatusBar = statusBarState
    Application.Calculation = calcState
    Application.EnableEvents = eventsState
 
    ' Note: this is a sheet-level setting
    ActiveSheet.DisplayPageBreaks = displayPageBreaksState
    
End Sub

Public Sub Ausgeblendetloeschen()
    Dim lngIndex As Long
    Application.ScreenUpdating = False
    For lngIndex = 256 To 1 Step -1
        If Columns(lngIndex).Hidden Then Columns(lngIndex).Delete
    Next
    For lngIndex = 65536 To 1 Step -1
        If Rows(lngIndex).Hidden Then Rows(lngIndex).Delete
    Next
    Application.ScreenUpdating = True
End Sub