Creating a macro with automatic creation of variable file types

[Macro_]

Hi all, So I currently have the current code. Currently the macro saves the files in this folder but I will need to save different files to more than one folder and want to see if I can set the macro up to create these folders e.g. for it to create a Test folder and save the files 1111 and 2222 in it rather than me having already created the folder Test where the files save...

These files are also saving updates for a number of different stores, I also am required to create a macro that will automatically add in new stores when necessary eg 3333 and area codes eg. testtwo etc.

 '==========>>
Option Explicit

 '---------->>
 Sub PassVariables()

    Call Tester(myYear:=2014, _
                 myQuarter:="Q4", _
                 myFolder:="TST", _
                 mySaveAsFolder:="Test", _
                 mySaveAsName:="1111", _
                 mySaveAsName2:="2222")
End Sub

 '---------->>
 Public Sub Main(myYear As Variant, myQuarter As String, _
                   myFolder As String, _
                   mySaveAsFolder As String, _
                   mySaveAsName As String, _
                   mySaveAsName2 As String)
     Dim WB As Workbook
     Dim WS As Worksheet
     Dim spath As String
     Dim sSaveAsPath As String
     Dim sFilename As String
     Dim sFullname As String
     Dim aStr As String

     aStr = myQuarter & " " & myYear
     spath = "X:\specific folder\" & myYear & "\" & aStr & "\TMT\" & myFolder
     sSaveAsPath = "X:\specific folder\" & myYear & "\" & aStr & "\TMT\" & mySaveAsFolder
     sFilename = "ST " & aStr & ".xlsm"
     sFullname = spath & "\" & sFilename

     ChDir spath
     Workbooks.Open Filename:=sFullname, Updatelinks:=0
     ActiveCell.Offset(-1, 0).FormulaR1C1 = mySaveAsName
     Set WS = ActiveSheet
     Set WB = Workbooks.Add(xlWBATWorksheet)
     WS.Range("A1:S84").Copy
     WB.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
     Application.CutCopyMode = False
     ChDir sSaveAsPath
     ActiveWorkbook.SaveAs Filename:=sSaveAsPath & "\" & mySaveAsName, _
                           FileFormat:=xlOpenXMLWorkbook, _
                           CreateBackup:=False
     ChDir spath
     Workbooks.Open Filename:=sFullname, Updatelinks:=0
     ActiveCell.Offset(-1, 0).FormulaR1C1 = mySaveAsName2
     Set WS = ActiveSheet
     Set WB = Workbooks.Add(xlWBATWorksheet)
     WS.Range("A1:S84").Copy
     WB.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
     Application.CutCopyMode = False
     ChDir sSaveAsPath
     ActiveWorkbook.SaveAs Filename:=sSaveAsPath & "\" & mySaveAsName2, _
                           FileFormat:=xlOpenXMLWorkbook, _
                           CreateBackup:=False
 End Sub
 '<<==========

 

[Worf]

This example shows how to create the folder,if it does not already exist:

Sub CallMain()
main "Q4", 2014, "TST", "1111", "2222"
End Sub


Sub main(q$, mY, myfolder$, san$, san2$)
Dim astr$, saf$, sap$, spath$, fullname$
astr = q & " " & mY
saf = Application.InputBox("Enter a folder name:", "Save As Folder", , , , , , 2)
sap = "C:\Accounts\" & mY & "\" & astr & "\TMT\" & saf
On Error Resume Next    ' creates folder if necessary
If Not ((GetAttr(sap) And vbDirectory) = vbDirectory) Then MkDir sap
On Error GoTo 0
spath = "C:\Accounts\" & mY & "\" & astr & "\TMT\" & myfolder
fullname = spath & "\" & "ST " & astr & ".xlsm"
Savediff fullname, san, sap
Savediff fullname, san2, sap
End Sub


Sub Savediff(fullname$, san$, sap$)
Dim ws As Worksheet, wb As Workbook
Workbooks.Open fullname, 0
ActiveCell.Offset(-1).Value = san
Set ws = ActiveSheet
Set wb = Workbooks.Add(xlWBATWorksheet)
ws.Range("a1:s84").Copy
wb.Sheets(1).Range("a1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ActiveWorkbook.SaveAs sap & "\" & san, xlOpenXMLWorkbook, , , , False
End Sub