2. Makro beim Speichern mit abspeichern

Bild

Betrifft: 2. Makro beim Speichern mit abspeichern
von: André
Geschrieben am: 17.07.2015 07:41:21

Guten Morgen,
ich lasse folgendes Makro zum speichern einer einzelnen Tabelle aus einer Datei laufen.

Sub Speichern_unter_neuem_Namen_Typ02()
Dim Neuer_Dateiname As String
Dim xlOldSheetscount As Integer
Rem Speicherpfad und Dateiname anfordern
Neuer_Dateiname = Application.GetSaveAsFilename(InitialFileName:="", fileFilter:="Excel- _
Arbeitsmappe (*.xlsm), *.xlsm")
Rem Abbruch wenn Dateiname leer
If Neuer_Dateiname = "Falsch" Then Exit Sub
Rem Anzahl Standardblätter merken
xlOldSheetscount = Application.SheetsInNewWorkbook
Rem Anzahl Standardblätter temporär umstellen
Application.SheetsInNewWorkbook = 1
Rem Gewünschten Inhalt kopieren
ActiveSheet.Range("A1:AH278").Copy
Rem Neue Arbeitsmappe einfügen
Workbooks.Add
Rem Bildschirmmeldungen deaktivieren
Application.DisplayAlerts = False
Rem Inhalt einfügen und Arbeitsmappe speichern
With ActiveWorkbook
    .Sheets(1).Range("A1").PasteSpecial xlPasteValues
    .Sheets(1).Range("A1").PasteSpecial xlPasteFormats
    .Sheets(1).Range("A1").PasteSpecial xlPasteColumnWidths
    
    .SaveAs Filename:=Neuer_Dateiname, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    .Close
End With
Rem Bildschirmmeldungen aktivieren
Application.DisplayAlerts = True
Rem Anzahl Standardblätter wiederherstellen
Application.SheetsInNewWorkbook = xlOldSheetscount
End Sub

-----------------------------------------------------
Ein zweites MAKRO soll beim speichern mit abgespeichert werden
Sub Drucken()
'Erstellt 29.06.2015 André Fungipani
'makro zum Drucken inkl. Druckbereichsanpassung
  
  
  
  Dim Zeile As Long, wks As Worksheet
  Set wks = ActiveSheet
  With wks
    Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row 'Letzte Zeile mit Daten in Spalte A
    'Letzte Zeile mit nummerischem Wert finden
    Do Until IsNumeric(.Cells(Zeile, 1).Text) Or Zeile = 10
      Zeile = Zeile - 1
    Loop
    .PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(Zeile, 20)).Address(ReferenceStyle:=xlA1) _
    .PrintOut Preview:=True
  End With
' Gehört zu 

Sub drucken
' End Sub

Leider weiß ich nicht, wie ich dem ersten Makro das beibringen soll.
Zusätzlioch möchte ich dass beim Speichern ein Button erzeugt wird, dem ich
dann das zweite Makro zuweisen kann.
Vielen Dank für eure Hilfe.
Grus
André

Bild

Betrifft: AW: 2. Makro beim Speichern mit abspeichern
von: Klexy
Geschrieben am: 17.07.2015 18:23:15
Erzeug keine neue Datei, sondern ein neues Blatt, in das du die entsprechenden Inhalte reinkopierst.
Dann lösch alle anderen Blätter und speicher die so bearbeitete Datei unter dem neuen Namen ab.
Den Druckerbutton erzeugst du am besten unter Einsatz der Makrorekorders.

Sub Druckerbutton_erstellen()
    ActiveSheet.Buttons.Add(275.25, 15, 282.75, 90).Select
    Selection.OnAction = "Drucken"
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Selection.Characters.Text = "Drucken"
    With Selection.Characters(Start:=1, Length:=7).Font
        .Name = "Calibri"
        .FontStyle = "Standard"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
    End With
    
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    With Selection.Font
        .Name = "Calibri"
        .FontStyle = "Fett"
        .Size = 20
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 3
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End WithEnd Sub

Dieses Makro aber erst laufen lassen, wenn die Datei unter neuem Namen gespeichert wird, sonst merkt sich die Ursprungsdatei den ("Button 1") und macht das nächste Mal einen ("Button 2").

 Bild

Beiträge aus den Excel-Beispielen zum Thema "2. Makro beim Speichern mit abspeichern"