Kopie von Lieferschein / Rechnung anlegen und Makro-Code löschen

Sub Excel_KopieDerAktuellenMappeAnlegen()
  
  Dim wb As Workbook, s_Kopie_NameFull As String
  
  Set wb = ActiveWorkbook
  
 ->Namen für Sicherung aufbereiten
  s_Kopie_NameFull = _
    wb.Path & \ & _
    Left(wb.Name, Len(wb.Name) - 4) & _
    Format(Now(), _yyyymmdd_hhnnss) & _
    Right(wb.Name, 4)
  
 ->Kopie der aktuellen Arbeitsmappe unter neuem Namen erstellen
  wb.SaveCopyAs Filename:=s_Kopie_NameFull
  
  Set wb = Nothing
End Sub

Sub Kopie_des_Lieferscheins()
  Dim orig_wb As Workbook, s_Kopie_NameFull As String
  Set orig_wb = ActiveWorkbook
 
 ->Namen für Sicherung aufbereiten
  s_Kopie_NameFull = _
    orig_wb.Path & \ & _
    Left(orig_wb.Name, Len(orig_wb.Name) - 4) & _
    Format(_) & Format(Range(E5)) & _
    Format(Now(), _yyyy-mm-dd_hh-nn-ss) & _
    Right(orig_wb.Name, 4)
    Workbooks.Add
    ActiveWindow.ActivateNext
    Cells.Select
    Selection.Copy
    ActiveWindow.ActivatePrevious
   ->Werte einfügen
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    ActiveWindow.ActivateNext
    Selection.Copy
    ActiveWindow.ActivatePrevious
    Cells.Select
   ->Formate einfügen
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Range(A1).Select
   ->Jetzt nicht ***orig_wb.SaveAs***, denn das würde die Originaldatei mitsamt Makros usw. speichern
   ->stattdessen ***ActiveWorkbook.SaveAs***, denn das ist die im Vordergrund befindliche Kopie
    ActiveWorkbook.SaveAs FileName:=s_Kopie_NameFull
    ActiveWorkbook.Close
    Range(A1).Select
   ->Vorlage wird auch gespeichert, bleibt aber offen.
    ActiveWorkbook.Save
  Set wb = Nothing
End Sub

Option Explicit
'******************************************************************************************
Sub Excel_KopieMitDatumAnlegenUndMakrosEntfernen()
  
  Dim s_Kopie_NameFull As String
  
  If Not Excel_KopieDerAktuellenMappeAnlegen(s_Kopie_NameFull) Then GoTo AUFRAEUMEN

  If Not Excel_CodeEntfernen(s_Kopie_NameFull) Then GoTo AUFRAEUMEN
  
  MsgBox ( _
    Es wurde eine Kopie der aktuellen Datei angelegt und von Code bereinigt. & vbLf & _
    vbLf & _
    aktuelle Datei: & vbLf & _
    ActiveWorkbook.FullName & vbLf & _
    vbLf & _
    Kopie: & vbLf & _
    s_Kopie_NameFull & vbLf & _
    vbLf & _
    :-)   :-)   :-)   :-)   :-)   :-)   :-)   :-)   :-)    & _
    :-)   :-)   :-)   :-)   :-)   :-)   :-)   :-)   :-)   )
AUFRAEUMEN:
End Sub
'******************************************************************************************
Private Function Excel_CodeEntfernen(s_Kopie_NameFull As String) As Boolean
  Dim wb As Workbook, x As Long
  Dim s_Name As String, l_Type As Variant
  
  Excel_CodeEntfernen = False
  
  Set wb = Workbooks.Open(FileName:=s_Kopie_NameFull)
 -> :-) :-) :-) Dabei werden Makros nicht ausgeführt :-) :-) :-) !!!
  
  On Error Resume Next
  
 ->Prüfen, ob überhaupt auf die VB-Komponenten zugegriffen werden kann
  x = wb.VBProject.VBComponents.Count
  If Err.Number <> 0 Then
    MsgBox ( _
      VBKomponenten können nicht gelöscht werden. & vbLf & vbLf & _
      Err.Description)
    GoTo AUFRAEUMEN
  End If
    
  For x = wb.VBProject.VBComponents.Count To 1 Step -1
    l_Type = wb.VBProject.VBComponents(x).Type
    Select Case l_Type
      Case 100->vbext_ct_Document    : DieseArbeitsmappe, Tabelle...
       ->Alle Codezeilen löschen
        With wb.VBProject.VBComponents(x).CodeModule: .DeleteLines 1, .CountOfLines: End With
      Case 1, 2, 3
       ->1 = vbext_ct_StdModule   : normale Module
       ->2 = vbext_ct_ClassModule : KlassenModule
       ->3 = vbext_ct_Forms       : Userform
        wb.VBProject.VBComponents.Remove wb.VBProject.VBComponents(x)
      Case Else
        MsgBox (Unbekannte VBComponent. Type =  & l_Type)
        GoTo AUFRAEUMEN
    End Select
    
  Next
 ->Schliessen mit speichern
  wb.Close Savechanges:=True
  
  Excel_CodeEntfernen = True
  
AUFRAEUMEN:
  Err.Clear
  On Error GoTo 0
  Set wb = Nothing
  Exit Function
End Function
'******************************************************************************************
Private Function Excel_KopieDerAktuellenMappeAnlegen(s_Kopie_NameFull As String) As Boolean
  
  Dim wb As Workbook
  
  Excel_KopieDerAktuellenMappeAnlegen = False
  
  Set wb = ActiveWorkbook
  
 ->Namen für Sicherung aufbereiten
  s_Kopie_NameFull = _
    wb.Path & \ & _
    Left(wb.Name, Len(wb.Name) - 4) & _
    Format(Now(), _yyyymmdd_hhnnss) & _
    Right(wb.Name, 4)
  
 ->Kopie der aktuellen Arbeitsmappe unter neuem Namen erstellen
  On Error Resume Next
  wb.SaveCopyAs FileName:=s_Kopie_NameFull
  If Err.Number <> 0 Then
    Err.Clear
    MsgBox ( _
      Kopie der aktuellen Mappe konnte nicht angelegt werden. & vbLf & _
      s_Kopie_NameFull)
    GoTo AUFRAEUMEN
  End If
  
  Excel_KopieDerAktuellenMappeAnlegen = True
AUFRAEUMEN:
  On Error GoTo 0
  Set wb = Nothing
End Function