Sub Save_ACTIVE_SHEET_to_DESKTOP()

'

' Save_ACTIVE_SHEET_to_DESKTOP Makro

'



'   https://www.herber.de/forum/messages/1984803.html - Topic "Makro (bitte prüfen) - Aktives Blatt auf Desktop speichern"

'   https://www.herber.de/forum/messages/1984812.html - Solution from 15 July 2024  - daniel

'   -----------------------------------------------------------------------------------------------------------------------------



'   *****************************************************   cd %$DESKTOP%   *****************************************************

'

'   English:

'   1. If the path is confirmed in the input field after the macro has been called up, the Excel file is saved on the desktop.

'      2nd line of the code ... lstrStdPfad = InputBox("Enter ..... format!", , Environ("USERPROFILE") & "\Desktop")

'      It is NOT necessary to enter the file extension, e.g. .xlsm! Inverted commas in the path are required!

'

'   2. If the input field is FILLED with a PATH after the macro is called - followed by a BACKSLASH '\',

'      then the Excel file is saved in this path. It is NOT necessary to enter the file extension, e.g. .xlsm!

'      A path with spaces must NOT be placed in inverted commas, otherwise an error message will be displayed!

'   -----------------------------------------------------------------------------------------------------------------------------



'   German:

'   1. Wird nach Aufruf des Makros der Pfad im Eingabefeld bestätigt, dann wird die Excel-Datei auf dem Desktop gespeichert.

'      2. Zeile im Code: ... lstrStdPfad = InputBox("Enter ..... format!", , Environ("USERPROFILE") & "\Desktop")

'      Die Angabe der Dateierweiterung, zB .xlsm ist NICHT erforderlich! Anführungszeichen im Pfad sind erforderlich!

'

'   2. Wird nach Aufruf des Makros das Eingabefeld mit einem PFAD - abschließend mit einem BACKSLASH '\' BEFÜLLT,

'      dann wird die Excel-Datei in diesem Pfad gespeichert. Die Erfassung der Dateierweiterung, zB .xlsm ist NICHT erforderlich!

'      Ein Pfad mit Leerzeichen darf NICHT in Anführungszeichen gesetzt werden, ansonsten erfolgt eine Fehlermeldung!

'   -----------------------------------------------------------------------------------------------------------------------------



    Dim lstrStdPfad As String

    lstrStdPfad = InputBox("Enter the path in which the sheet is to be saved - the file name extension (.xl??) is automatically added according to the file format!", , Environ("USERPROFILE") & "\Desktop")

        If Mid(Path, 2, 1) <> ":" Then

            Path = lstrStdPfad

        End If

    Select Case Right(Path, 1)

        Case ""

        GoTo ErrorHandler

        Case Is <> "\"

        Path = Path & "\"

    End Select

    ActiveSheet.Copy

    On Error GoTo ErrorHandler

'    ActiveWorkbook.SaveAs Filename:=path & ActiveSheet.Name                   => Excel 2003

'    ActiveWorkbook.SaveAs Filename:=path & ActiveSheet.Name, FileFormat:=52   => Excel 2010: The file name extension can be omitted,

'    https://www.herber.de/forum/archiv/1380to1384/1380461_Excel_2010_per_makro_tabellenblatt_in_neue_Datei.html  => Excel adds them automatically according to the file format.

    ActiveWorkbook.SaveAs Filename:=Path & ActiveSheet.Name, FileFormat:=52

ActiveWorkbook.Close Savechanges:=False

Exit Sub

ErrorHandler:

    Select Case Err.Number

        Case 1004

            MsgBox ("Saving was NOT successful! - Check the path...")

            ActiveWorkbook.Close Savechanges:=False

        Case Else

    End Select

End Sub