Save Worksheets As New File To Specific Folder

[k0st4din]

Hello everyone,
I posted my question on this site(Save 2 Sheet's - criteria in a particular cell - VBA Express Forum), but so far no one can give me an answer. Why I write here in the hope someone can help me.
After much searching on the internet, I still have not managed to find a solution to my problem.
So I turn to you, great minds with the hope you can help me.
That is the difficulty with which I can do:
On the desktop I have a folder with a name in it I have 70 folders with names of cities, have 1 excel file with 3 sheets (sheet1 (it manage all actions (macros) that I have), sheet2 and sheet3), - my problem is how to make a macro to a button placed on sheet1 and when I press this button to check the macro cell C5 in Sheet2 and depending on which city is written in cell C5, let me open the folder on the desktop and then the folder name of the city to allow me to write the title of the new file and my copy two sheets (Sheet2 and Sheet3).
I will try to simplify it with an example:
1 workbook - example name Countries
3 sheets - Sheet1 - permanent, sheet2 and Sheet3 - create a button macro in Sheet1.
in Sheet2 - Documentary write things and the most important is my cell C5, which set the town.
in Sheet3 - write in many cells, names, addresses, workplaces, and many other things.
Back in sheet1 - I have my button.
Press the button and the macro (here is the big problem) examine cell C5 in sheet2, dialog box opens (I mean Save as ........) (but I've already put in the macro path to the folder "Countries" and he should find a folder with the name of the city that is in cell C5, and open the folder) I wrote a title and pressing Save - Sheet2 and Sheet3 already be present in the folder and they're so each subsequent time.
I hope you understand me, I tried to explain it in the easiest possible way.
Thank you in advance!
I found this macro, which is roughly good, but you'll have to change it after you save the new file name can be set to open a folder on the desktop and automatically find the folder with the name of the city (taken from cell C5) and save it there.

Option Explicit 
Sub TwoSheetsAndYourOut() 
    Dim NewName As String 
    Dim nm As Name 
    Dim ws As Worksheet 
     
    If MsgBox("Copy specific sheets to a new workbook" & vbCr & _ 
    "New sheets will be pasted as values, named ranges removed" _ 
    , vbYesNo, "NewCopy") = vbNo Then Exit Sub 
    With Application 
        .ScreenUpdating = False 
         
         '       Copy specific sheets
         '       *SET THE SHEET NAMES TO COPY BELOW*
         '       Array("Sheet Name", "Another sheet name", "And Another"))
         '       Sheet names go inside quotes, seperated by commas
        On Error Goto ErrCatcher 
        Sheets(Array("Sheet2", "Sheet3")).Copy 
        On Error Goto 0 
         
         '       Paste sheets as values
         '       Remove External Links, Hperlinks and hard-code formulas
         '       Make sure A1 is selected on all sheets
        For Each ws In ActiveWorkbook.Worksheets 
            ws.Cells.Copy 
            ws.[A1].PasteSpecial Paste:=xlValues 
            ws.Cells.Hyperlinks.Delete 
            Application.CutCopyMode = False 
            Cells(1, 1).Select 
            ws.Activate 
        Next ws 
        Cells(1, 1).Select 
         
         '       Remove named ranges
        For Each nm In ActiveWorkbook.Names 
            nm.Delete 
        Next nm 
         
         '       Input box to name new file
        NewName = InputBox("Please Specify the name of your new workbook", "New Copy") 
         
         '       Save it with the NewName and in the same directory as original.
         ' I am referring here to make a change, ie once
         ' I set my path to desktop - how then to automatically find the name of the city and there to save?
        ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls" 'perhaps to use it or something else -> strName = Range("C5") ActiveWorkbook.SaveAs Filename:= ThisWorkbook.Path & "\" & strName
        ActiveWorkbook.Close SaveChanges:=False 
         
        .ScreenUpdating = True 
    End With 
    Exit Sub 
     
ErrCatcher: 
    MsgBox "Specified sheets do not exist within this workbook" 
End Sub

[Admin]

Hi

try 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)
    
    strCity = ThisWorkbook.Worksheets("Sheet2").Range("c5")
1:
    If CBool(Len(Dir(strDesktopFolder & "\" & strCity, vbDirectory))) Then
        Set wbkActive = ThisWorkbook
        Set wbkNew = Workbooks.Add(xlWBATWorksheet)
        wbkActive.Worksheets(Array("Sheet2", "Sheet3")).Copy before:=wbkNew.Worksheets(1)
        strFName = Application.InputBox("File Name", "FileName", Type:=2)
        wbkNew.SaveAs strDesktopFolder & "\" & strCity & "\" & strFName, 51
        wbkNew.Close 0
        Set wbkNew = Nothing
    Else
        If MsgBox("Folder '" & strDesktopFolder & "\" & strCity & "' does not exist." & vbLf & _
            "Do you want create the folder?", vbYesNo) = vbYes Then
            MkDir strDesktopFolder & "\" & strCity
            GoTo 1
        Else
            Exit Sub
        End If
    End If
    
End Sub

[k0st4din]

Hello,
thank you very much for your cooperation on your part.
Maybe I wrong somewhere and therefore attach files and pictures to make clear what I mean. I hope you can understand me more clearly what I need, having in mind that this is only an example.
I will try to explain:
I want to just copy Sheet2 and Sheet3.
1 - write all sorts of things, but the most important is the cell C5 - if there is the city of London.
2 - Press the button in Sheet1.
3 - shows a window in which to write my name (title of the new workbook)
4 - automatically finds the folder (in this example "States" - can himself to show the path to it in the macro)
5 - According to the city in cell C5 - opens the folder and there save the new workbook with the name written by me. (in the present case because it keeps on the old document)
Here is link to download samples -> DOX.bg -

[Admin]

Hi

Have you tried the code?

[k0st4din]

Hello Admin,
I tried to do, and that is why I wrote again with a little more clarification.
Again and again I repeat that I could be wrong somewhere, but the code does the following: climbing inscription to ask me the title, I write as 123 and he took the name from cell C5 makes my folder of the state and within her again the same name (of excel file) the cell C5. In other words: If you have London in cell C5 - make folder London and excel file is also London. If you change the data in the cells, but the city is again the same, then replace it on the old excel file, and I do not want so, and when climbing allows me to me to ask myself the title of the excel file and according to the country to save it in folder.
I beg you look at the attached photos.
Greetings and thank you very much!

[Admin]

Hi

replace this line

wbkNew.SaveAs strDesktopFolder & "\" & strCity & "\" & strCity, 51

with

wbkNew.SaveAs strDesktopFolder & "\" & strCity & "\" & strFName, 51

[k0st4din]

Hello Admin,
receive and now everything is fine.
if you can tell me where wrong with putting the path to my folder because everything I saved on the desktop, but I want to ask him a path to my folder. I'll show you what I do, but I do not get things right.

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)
    
    strCity = ThisWorkbook.Worksheets("Sheet2").Range("c5")
1:
    If CBool(Len(Dir(strDesktopFolder & "\" & strCity, vbDirectory))) Then
        Set wbkActive = ThisWorkbook
        Set wbkNew = Workbooks.Add(xlWBATWorksheet)
        wbkActive.Worksheets(Array("Sheet2", "Sheet3")).Copy before:=wbkNew.Worksheets(1)
        strFName = Application.InputBox("File Name", "FileName", Type:=2)
        wbkNew.SaveAs strDesktopFolder & "C:\Users\dracon_\Desktop\Countries" & strCity & "\" & strFName, 51'I put my path to the folder but does 
                                                                                                        ' not want to get probably 
                                                                                                        ' wrong again!? Please help me.
                                                                                                        ' My heartfelt thanks!
        wbkNew.Close 0
        Set wbkNew = Nothing
    Else
        If MsgBox("Folder '" & strDesktopFolder & "\" & strCity & "' does not exist." & vbLf & _
            "Do you want create the folder?", vbYesNo) = vbYes Then
            MkDir strDesktopFolder & "\" & strCity
            GoTo 1
        Else
            Exit Sub
        End If
    End If
    
End Sub

[Admin]

Hi

try 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 = Application.InputBox("File Name", "FileName", Type:=2)
    'wbkNew.SaveAs strDesktopFolder & "C:\Users\dracon_\Desktop\Countries" & strCity & "\" & strFName, 51 'I put my path to the folder but does
    wbkNew.SaveAs strFolderToSave & "\" & strFName, 51
                                                                                                    ' not want to get probably
                                                                                                    ' wrong again!? Please help me.
                                                                                                    ' My heartfelt thanks!
    wbkNew.Close 0
    Set wbkNew = Nothing
    
End Sub

[k0st4din]

Hello Admin,
mistake somewhere in the code, there is something that we can not understand or I did not explain it or you can not understand. I will try to explain again.
1 - Press the button in sheet1
2 - window pops up and asks how to say your file?
3 - Automatically finds the path (or leave me a place in the code where I give myself a way) to a folder Countries
4 - and then by the city of Sheet2, cell 5 to automatically save it in the folder with the name of the city, but what I wrote title (2 *)
I hope this time we can to do that.
I am most grateful for the work of your hand.

[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