Changes to macro to save workbook to desktop

Question

Hello all!

I am currently using the following code to save the workbook onto the desktop, based on a user inputted name.

Sub SaveAs()

Dim FName           As String

Dim FPath           As String

FPath = "\FILESERVER\RedirectedFolders\jack.morrish\Desktop"

    Range("I3").Value = FName ' optional

If Range("I3").Value = vbNullString Then

    FName = InputBox("Enter the job number.")

    If FName = vbNullString Then

        Exit Sub

    End If

End If

ThisWorkbook.SaveAs Filename:=FPath & "" & FName & ".xlsx", _

    FileFormat:=xlOpenXMLWorkbook

End Sub

However I have a few issues:

1.  This sheet will be used by multiple users.  I want to use one central template for everyone, but because we have redirected folders here, the code will currently only save to my desktop, no one elses.  Is there a way to save to each individuals desktop?  Somehow pull through their redirected desktop path into the file save path?
2.  Can the code be adapted to remove the VBA code from the sheet when saving?  It is saving as xlsm, and I currently have to click "Yes" to "continue saving as a macro free workbook" message every time I save.  Not a big deal would just be nice.
3.  I would like the workbook save name to be as follows:  Parts List for (User inputted number) eg Parts list for 123456.

Appreciated your help on this, thanks very much!

Jack

Answer 1

Jack,

Try this version:

Sub CreateDesktopFileV2()

    Dim WSHShell As Object

    Dim DesktopPath As String

    Dim FName As String

    Dim wb As Workbook

    Set WSHShell = CreateObject("WScript.Shell")

    DesktopPath = WSHShell.SpecialFolders("Desktop")

    FName = ActiveSheet.Range("C6").Value

    If FName = "" Then

        MsgBox "There is no name for the file in cell C6"

        Exit Sub

    End If

    Application.DisplayAlerts = False

    ActiveSheet.Copy

    Set wb = ActiveWorkbook

    wb.SaveAs Filename:=DesktopPath & "" & FName & ".xlsx", _

        FileFormat:=xlOpenXMLWorkbook

    wb.Close False

    Application.DisplayAlerts = True

    Set WSHShell = Nothing

    MsgBox "A file has been saved on your desktop."

End Sub

Answer 2

Try this - You will need to use a reference in your project to Microsoft Scripting Runtime to find the desktop.  I should note that I have never worked with redirected folders - but the code does everything else you wanted, so try it out.

Sub CreateDesktopFile()

    Dim WSHShell As Object

    Dim DesktopPath As String

    Dim FName As String

    Set WSHShell = CreateObject("WScript.Shell")

    DesktopPath = WSHShell.SpecialFolders("Desktop")

    FName = "Parts List for " & Application.InputBox("Enter the job number.", Type:=2)

    If FName = "Parts List for " Then Exit Sub

    Application.DisplayAlerts = False

    ThisWorkbook.SaveAs Filename:=DesktopPath & "" & FName & ".xlsx", _

    FileFormat:=xlOpenXMLWorkbook

    Application.DisplayAlerts = True

    Set WSHShell = Nothing

    MsgBox "A file has been saved on your desktop."

    ThisWorkbook.Close False

End Sub

Answer 3

Hello Bernie,

Lifesaver! That is awesome thanks very much.  Works perfectly on all machines on the network.

a couple of small changes that i've been playing with and for some reason can't get to work - could you help me out here too?  Excuse my ignorance :)

a) Instead of choosing filepath based on an input box, base it on a cell from the sheet (eg C6)

b) Instead of saving the whole workbook, save just the active sheet

thanks very much for all your help.

Jack

Answer 4

Bernie - thanks very much!

All code works perfectly.

Have a great day, thanks again.

Jack