MACRO - Create Folder/Subfolder based on Today and single cell values - Create *.xlsx in that folder

[JoAvg]

Hello everyone, newcomer here.

I have a book with two main sheets: Overview with ref's to sheet Formulas which is a bunch of index/lookup/search functions.
I am in need of two macros in Overview sheet, that perform the following tasks.

Macro 1
In a Desktop folder named Delivery, the macro:
a) Creates a folder with Today's date
b) Inside DATE folder it creates a subfolder named after the City of the assignment is at (cell Formulas!A5)
c) Inside CITY folder it creates a subfolder named after the address of the assignment (cell Formulas!A6)

The end result would look something like this:
C:\Users\user\Desktop\Delivery\15 05 2022 \City1 \Address1

I review about 20-40 assignments from 11 cities daily, so this means that:
a) The macro works on every reviewed assignment individually, not on a range
b) The date folder will -of course- be created once
c) The addresses must reside in their respective city folders, so if City found more than once, any duplicates should be avoided.

Macro 2

The second macro, is one that copies the range FORMULAS!A53:I54, creates a new Station.xlsx file and saves in the respective folder I am reviewing. For example if in 16 05 2022 I am reviewing Address22 in City4 , the end result would be.
C:\Users\user\Desktop\Delivery\16 05 2022 \City4 \Address22 \Station.xlsx

The two Macros should work independent from one another, because I do not want to use the second on every review.

Any help would be greatly appreciated.
Cheers!

[#2]

@JoAvg 

Sub Macro1()
    Dim sPath As String
    Dim sDate As String
    Dim sCity As String
    Dim sAddress As String
    sPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    sDate = Format(Date, "dd mm yyyy")
    sPath = sPath & "\Delivery\" & sDate
    If Dir(sPath, vbDirectory) = "" Then
        MkDir sPath
    End If
    sCity = Worksheets("Formulas").Range("A5").Value
    sPath = sPath & "\" & sCity
    If Dir(sPath, vbDirectory) = "" Then
        MkDir sPath
    End If
    sAddress = Worksheets("Formulas").Range("A6").Value
    sPath = sPath & "\" & sAddress
    If Dir(sPath, vbDirectory) = "" Then
        MkDir sPath
    End If
End Sub

[#3 · Accepted solution]

@JoAvg 

Sub Macro2()
    Dim wbkT As Workbook
    Dim wshS As Worksheet
    Dim wshT As Worksheet
    Dim sPath As String
    Dim sDate As String
    Dim sCity As String
    Dim sAddress As String
    Dim sFile As String
    Set wshS = ThisWorkbook.Worksheets("Formulas")
    Set wbkT = Workbooks.Add(xlWBATWorksheet)
    Set wshT = wbkT.Worksheets(1)
    wshT.Range("A53:I54").Value = wshS.Range("A53:I54").Value
    sPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    sDate = Format(Date, "dd mm yyyy")
    sPath = sPath & "\Delivery\" & sDate
    sCity = wshS.Range("A5").Value
    sPath = sPath & "\" & sCity
    sAddress = wshS.Range("A6").Value
    sPath = sPath & "\" & sAddress
    sFile = "Station.xlsx"
    sPath = sPath & "\" & sFile
    wbkT.SaveAs Filename:=sPath, FileFormat:=xlOpenXMLWorkbook
    wbkT.Close
End Sub

[#4]

These worked both like a charm.
Thank you a ton!!!

[#5]

Great

[#6]

@Hans Vogelaar 

Hello Hans,

If possible, I would like a slight modification to the second code.

The code copies and pastes the range at the same place: i.e. A53:I54.

Any chance it pastes at A1?

Also, if possible, can the formatting also be pasted?

Thank you again.

[#7]

@JoAvg 

Change the line

    wshT.Range("A53:I54").Value = wshS.Range("A53:I54").Value

to

    wshS.Range("A53:I54").Copy
    wshT.Range("A1").PasteSpecial Paste:=xlPasteValues
    wshT.Range("A1").PasteSpecial Paste:=xlPasteFormats

[#8]

@Hans Vogelaar 

YOU ARE A BEAST!!!

THANK YOU!!!

[#9]

Hey