Save 2 Worksheets As New File To Specific Folder

nevidim_ · June 6th, 2013, 08:58 AM

Hello everyone,
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.

Code:

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

or

Code:

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 not want to get probably wrong again!? Please help me.
    wbkNew.SaveAs strFolderToSave & "\" & strFName, 51
    wbkNew.Close 0
    Set wbkNew = Nothing
    
End Sub