AW: Arbeitsblatt SaveAs Dateinamen+Arbeitsblattnamen
29.03.2019 15:23:01
Denis
Hi,
ich hab nun das Makro Projekt abgeschlossen.
Wenn ihr trotzdem noch Tipps habt, dann gerne her damit, ich muss noch viel lernen.
Danke nochmal an alle die geholfen haben.
Hier ist das fertige Makro, dass in Zukunft verwendet wird.
Nur wenn der Nutzer des Makros dreimal versucht unter einem bereits verwendeten Namen zu speichern, kommt es zur Unterbrechung, ansonsten sind mir keine Möglichkeiten bekannt wie das Makro scheitern kann.
Public Sub Blatt_Als_Neue_Datei_speichern()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Speicherpfad As String
Dim Dateiname As String
Dim Arbeitsblatt As String
Dim SpeichernUnter As String
Speicherpfad = ActiveWorkbook.Path
Dateiname = ActiveWorkbook.Name
Dateiname = VBA.Left(Dateiname, VBA.InStr(1, Dateiname, ".") - 1)
Arbeitsblatt = ActiveSheet.Name
If Dir(Speicherpfad & "\" & Dateiname & " - " & Arbeitsblatt & ".xlsm") "" Then
On Error GoTo NamenAendern
ActiveSheet.Select
Cells.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
ActiveSheet.Name = Arbeitsblatt
Application.CutCopyMode = False
i = MsgBox(" Neuen Namen auswählen?" & Chr(13) & _
"" & Chr(13) & _
" Sonst Abbrechen" & Chr(13), 1 + vbQuestion, "Name bereits vorhanden")
If i = 2 Then GoTo FehlerEnding
Dim Name
Name = Application.GetSaveAsFilename(Speicherpfad & "\" & Dateiname & " - " & _
Arbeitsblatt & "(1)" & ".xlsm", fileFilter:="Microsoft Excel-Arbeitsmappe (*.xlsm), *.xlsm") 'Pfad evtl. anpassen!
If Name False Then
ActiveWorkbook.SaveAs Name, FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Else: GoTo FehlerEnding
End If
ActiveWorkbook.Close
GoTo Ending
Else:
SpeichernUnter = Speicherpfad & "\" & Dateiname & " - " & Arbeitsblatt & ".xlsm"
ActiveSheet.Select
Cells.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
ActiveSheet.Name = Arbeitsblatt
ActiveWorkbook.SaveAs Filename:=SpeichernUnter, FileFormat:= _
xlOpenXMLWorkbookMacroEnabled
ActiveWorkbook.Close
GoTo Ending
End If
NamenAendern:
Application.CutCopyMode = False
i = MsgBox("Anderen Namen auswählen" & Chr(13) & _
"" & Chr(13) & _
"Sonst Abbrechen" & Chr(13), 1 + vbExclamation, "Name bereits vorhanden")
If i = 2 Then GoTo FehlerEnding
Dim Name2
Name2 = Application.GetSaveAsFilename(Speicherpfad & "\" & Dateiname & " - " & Arbeitsblatt _
& "(2)" & ".xlsm", fileFilter:="Microsoft Excel-Arbeitsmappe (*.xlsm), *.xlsm") 'Pfad evtl. anpassen!
If Name2 False Then
ActiveWorkbook.SaveAs Name2, FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Else: GoTo FehlerEnding
End If
ActiveWorkbook.Close
GoTo Ending
FehlerEnding:
ActiveWorkbook.Close SaveChanges:=False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Die Datei konnte nicht gespeichert werden", vbExclamation
Exit Sub
Ending:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Die Datei wurde erfolgreich gespeichert", vbInformation
End Sub
Viele Grüße
Denis