vba - сохранение файла в личном коде рабочего стола

Question

У меня есть следующий код, разработанный таким образом, чтобы я мог быстро сохранить его на рабочем столе и затем поместить файл в папку. Этот код работает нормально, если файл уже сохранен с расширением.xls,.csv,.xlsx или.xlsm, однако, когда файл НЕ сохраняется, я получаю только всплывающие окна с сообщениями, и ничего не происходит. Я думал о реструктуризации с использованием CASE STATEMENT с правильным (activeworkbook.name, 4), но не знал, как структурировать, так как я не знаком с этими утверждениями. Спасибо.

Sub SavetoDesktop()

'this macro will save the activesheet into the default path giving it the current name and xlsx extension

    Dim fname As String

'    If Right(ActiveWorkbook.Name, 5) <> ".xlsx" And Right(ActiveWorkbook.Name, 5) <> ".xls" And _
'    Right(ActiveWorkbook.Name, 5) <> ".xlsm" And Right(ActiveWorkbook.Name, 5) <> ".csv" Then

                 If Right(ActiveWorkbook.Name, 5) = ".xlsx" Then
                         fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xlsx", "") & ".xlsx"
                         ActiveWorkbook.SaveAs Filename:=fname
                 Else
                     MsgBox "Not an .xlsx file!"
                     ActiveWorkbook.SaveAs Filename:="C:\Users\mmirabelli\Desktop\" & ActiveWorkbook.Name & ".xlsx"
                 End If

                 If Right(ActiveWorkbook.Name, 4) = ".csv" Then
                         fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".csv", "") & ".csv"
                         ActiveWorkbook.SaveAs Filename:=fname
                 Else
                     MsgBox "Not an .csv file!"
                     MsgBox ActiveWorkbook.Name

                 End If

                 If Right(ActiveWorkbook.Name, 4) = ".xls" Then
                         fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xls", "") & ".xls"
                         ActiveWorkbook.SaveAs Filename:=fname
                  Else
                     MsgBox "Not an .xls file!"
                  End If

                 If Right(ActiveWorkbook.Name, 5) = ".xlsm" Then
                         fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xlsm", "") & ".xlsm"
                         ActiveWorkbook.SaveAs Filename:=fname
                 Else
                    MsgBox "Not an .xlsm file!"
                 End If

'     Else
'
'     ActiveWorkbook.SaveAs Filename:="C:\Users\mmirabelli\Desktop\" & ActiveWorkbook.Name & ".xlsx"

'     End If


'MsgBox Application.DefaultFilePath
'MsgBox ActiveWorkbook.Name
'
'    ActiveWorkbook.SaveAs Filename:=fname
'
End Sub

Answer 1

Это то, что вы пытаетесь сделать?

Sub SavetoDesktop()
    'this macro will save the activesheet into the default path giving it the current name and xlsx extension
    Dim fname As String
    Select Case True
        Case ActiveWorkbook.Name Like "*.xlsx", _
             ActiveWorkbook.Name Like "*.xlsm", _
             ActiveWorkbook.Name Like "*.xls", _
             ActiveWorkbook.Name Like "*.csv"
             fname = Application.DefaultFilePath & "\" & ActiveWorkbook.Name
        Case Else
            msgBox "No file extension. Will be saved as .xlsx in the Desktop folder"
            fname = Environ$("HOMEDRIVE") & Environ$("HOMEPATH") & "\Desktop\" & ActiveWorkbook.Name & ".xlsx"
    End Select

    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.SaveAs Filename:=fname
    msgBox IIf(Err.Number, "Could not Save", "Saved")
    Application.DisplayAlerts = True
End Sub

Answer 2

Спасибо за ответ. Я попробовал это и обнаружил следующее: 1) При попытке сохранить Book1 всплыло окно " msgbox", после чего появилось сообщение "не удалось сохранить", и оно не сохранялось на рабочем столе. Для уже сохраненных файлов я только что получил сообщение "не удалось сохранить". Я никогда не видел синтаксис "LIKE" и " " (по крайней мере, в VBA, видел в SQL). Используется ли подобное для шаблонов в строках? и " " функционирует ли как подстановочный знак для чего-либо до или после? Я также использовал утверждение выбора случая и нашел, что это было успешно. Я выложу ниже. Еще раз спасибо за ответ.

Sub SavetoDesktop()

'this macro will save the activesheet into the default path giving it the current name and xlsx extension,
' unless it already has an extension of the 4 most common formats, then it will simply save over 
'(replace) the current file w a prompt


Dim fname As String

On Error GoTo errormessage

Select Case Right(ActiveWorkbook.Name, 4)
Case "xlsx"
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xlsx", "") & ".xlsx"
ActiveWorkbook.SaveAs Filename:=fname
Case ".xls"
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xls", "") & ".xls"
ActiveWorkbook.SaveAs Filename:=fname
Case "xlsm"
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xlsm", "") & ".xlsm"
ActiveWorkbook.SaveAs Filename:=fname
Case ".csv"
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".csv", "") & ".csv"
ActiveWorkbook.SaveAs Filename:=fname
Case Else
MsgBox "Saved to desktop as .xlsx file!"
ActiveWorkbook.SaveAs Filename:="C:\Users\mmirabelli\Desktop\" & ActiveWorkbook.Name & ".xlsx"
End Select

Exit Sub

errormessage:
MsgBox "No action", vbInformation + vbOKCancel, Time()

End Sub