Excel Macro prompt box to save to another folder

[NormChart55]

Hello,

I am trying to tweak this code below to instead of asking for a new name of the file, to choose a new location to save the file to. Basically, some users will have one drive active and others will be using their personal desktop to save files. So I am trying to automatically save to personal desktop but when they do not have the User folder/using one drive it allows them to press 'Yes' and choose another location for the file? The 'Path = "C:\TEST\" is not available and only being used to test if the prompts work.

Dim Path As String
Dim FileName As String
Dim dt As String
dt = Format(CStr(Now), "yyyy_mm_dd_hh_mm")
user = Environ("Username")
    Path = "C:\TEST\"
    Desktop = "C:\Users\" & user & "\Desktop\"
    FileName = "Backorder"

ActiveSheet.Range("C5:H50000").Copy
  Set NewBook = Workbooks.Add
  NewBook.Worksheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
          :=False, Transpose:=False

    Columns("A:E").Select
    Columns("A:E").EntireColumn.AutoFit
     
     
On Error GoTo NoSave
  ActiveWorkbook.SaveAs FileName:=Path & FileName & " " & dt & ".xls", FileFormat:=xlNormal

NoSave:
On Error GoTo 0
Application.EnableEvents = True
Answer = MsgBox("Cannot save the file as it appears the folder and/or desktop path is not available." & _
            Chr$(13) & "Do you wish to manually save?", vbYesNo, ThisWorkbook.Name)
            
 If Answer = vbNo Then
        'Code for No button Press
        MsgBox "You pressed NO!"
    Else
        'Code for Yes button Press
        NewFilename = InputBox("Please enter new filename", _
         "filename", "Type your filename here")
        If NewFilename <> "" Then
            FName = NewFilename
            Resume
        End If
  End If

 

[dmt32]

Hi,
try checking for valid folder / path first & if cannot be found, give users option to select another folder or add add a new one

See if this update to your code helps

Sub NormChart55()
    Dim FolderPath  As Variant
    Dim rng         As Range
    Dim FileName    As String, dDate As String
    Dim Answer      As VbMsgBoxResult
    Dim NewBook     As Workbook
    
    dDate = Format(CStr(Now), "yyyy_mm_dd_hh_mm")
    
    FolderPath = "C:\TEST\"
    FileName = "Backorder" & " " & dDate & ".xls"
    
    'check folder exists
    If Dir(FolderPath, vbDirectory) = vbNullString Then
        Answer = MsgBox("Cannot save the file As it appears the folder and/or desktop path Is Not available." & _
                 Chr$(13) & "Do you wish To manually save?", 36, ThisWorkbook.Name)
        If Answer = vbNo Then Exit Sub
        
        'get folder path
        FolderPath = GetFolder
        'cancel pressed
        If FolderPath = False Then Exit Sub
    End If
    
    On Error GoTo myerror
    Application.ScreenUpdating = False
    
    'size copy range
    With ActiveSheet
        Set rng = .Range("C5").Resize(.Cells(.Rows.Count, "C").End(xlUp).Row - 4, 6)
    End With
    
    'add new workbook
    Set NewBook = Workbooks.Add(1)
    
    'copy & paste values
    rng.Copy
    
    With NewBook.Worksheets(1)
        .Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                                                    SkipBlanks:=False, Transpose:=False
        .Columns("A:E").EntireColumn.AutoFit
    End With
    
    'save & close workbook
    With NewBook
        .SaveAs FileName:=FolderPath & FileName, FileFormat:=xlExcel8
        'optional
        .Close False
    End With
    
myerror:
    With Application
        .CutCopyMode = False: .ScreenUpdating = True
    End With
    'report errors
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

You will need to adjust code to meet actual project need as required.

Place this function in a STANDARD module

Function GetFolder(Optional ByVal FolderPath As Variant) As Variant
    Dim Folder      As FileDialog
    Dim Item        As Variant
    
    If IsMissing(FolderPath) Then FolderPath = ThisWorkbook.Path
    Set Folder = Application.FileDialog(msoFileDialogFolderPicker)
    
    With Folder
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .ButtonName = "Select Folder"
        .InitialFileName = FolderPath
        If .Show <> -1 Then
            Item = False
        Else
            Item = .SelectedItems(1) & "\"
        End If
    End With
    
ExitFunction:
    GetFolder = Item
    Set Folder = Nothing
End Function

Function can be used in other places in your project if needed

Hope Helpful

Dave

 

[NormChart55]

Hi,
try checking for valid folder / path first & if cannot be found, give users option to select another folder or add add a new one

See if this update to your code helps

Sub NormChart55()
    Dim FolderPath  As Variant
    Dim rng         As Range
    Dim FileName    As String, dDate As String
    Dim Answer      As VbMsgBoxResult
    Dim NewBook     As Workbook
   
    dDate = Format(CStr(Now), "yyyy_mm_dd_hh_mm")
   
    FolderPath = "C:\TEST\"
    FileName = "Backorder" & " " & dDate & ".xls"
   
    'check folder exists
    If Dir(FolderPath, vbDirectory) = vbNullString Then
        Answer = MsgBox("Cannot save the file As it appears the folder and/or desktop path Is Not available." & _
                 Chr$(13) & "Do you wish To manually save?", 36, ThisWorkbook.Name)
        If Answer = vbNo Then Exit Sub
       
        'get folder path
        FolderPath = GetFolder
        'cancel pressed
        If FolderPath = False Then Exit Sub
    End If
   
    On Error GoTo myerror
    Application.ScreenUpdating = False
   
    'size copy range
    With ActiveSheet
        Set rng = .Range("C5").Resize(.Cells(.Rows.Count, "C").End(xlUp).Row - 4, 6)
    End With
   
    'add new workbook
    Set NewBook = Workbooks.Add(1)
   
    'copy & paste values
    rng.Copy
   
    With NewBook.Worksheets(1)
        .Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                                                    SkipBlanks:=False, Transpose:=False
        .Columns("A:E").EntireColumn.AutoFit
    End With
   
    'save & close workbook
    With NewBook
        .SaveAs FileName:=FolderPath & FileName, FileFormat:=xlExcel8
        'optional
        .Close False
    End With
   
myerror:
    With Application
        .CutCopyMode = False: .ScreenUpdating = True
    End With
    'report errors
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

You will need to adjust code to meet actual project need as required.

Place this function in a STANDARD module

Function GetFolder(Optional ByVal FolderPath As Variant) As Variant
    Dim Folder      As FileDialog
    Dim Item        As Variant
   
    If IsMissing(FolderPath) Then FolderPath = ThisWorkbook.Path
    Set Folder = Application.FileDialog(msoFileDialogFolderPicker)
   
    With Folder
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .ButtonName = "Select Folder"
        .InitialFileName = FolderPath
        If .Show <> -1 Then
            Item = False
        Else
            Item = .SelectedItems(1) & "\"
        End If
    End With
   
ExitFunction:
    GetFolder = Item
    Set Folder = Nothing
End Function

Function can be used in other places in your project if needed

Hope Helpful

Dave

Thanks. This was helpful and is achieving the desired result. I will look at this and work it into all of my save processes. thanks for the help, you rock!

 

[dmt32]

Most welcome, glad suggestion helped & appreciate your feedback

Dave