Save Worksheets As New File To Specific Folder

[Admin]

Hi

Like this ?

Option Explicit

Sub kTest()
    
    Dim strDesktopFolder    As String
    Dim strCity             As String
    Dim wbkActive           As Workbook
    Dim wbkNew              As Workbook
    Dim strFName            As String
    
    'strDesktopFolder = CreateObject("WScript.Shell").Specialfolders(10)
    
    Dim strFolderToSave     As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show = -1 Then
            strFolderToSave = .SelectedItems(1)
        Else
            'no folder selected
            Exit Sub
        End If
    End With
    
    strCity = ThisWorkbook.Worksheets("Sheet2").Range("c5")
    
    Set wbkActive = ThisWorkbook
    Set wbkNew = Workbooks.Add(xlWBATWorksheet)
    wbkActive.Worksheets(Array("Sheet2", "Sheet3")).Copy before:=wbkNew.Worksheets(1)
    strFName = strCity ' Application.InputBox("File Name", "FileName", Type:=2)
    wbkNew.SaveAs strFolderToSave & "\" & strFName, 51
    wbkNew.Close 0
    
    Set wbkNew = Nothing
    
End Sub