Forum Discussion

JoAvg's avatar
JoAvg
Brass Contributor
May 15, 2022
Solved

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

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!

excel
Macros and VBA
office 365
  • HansVogelaar's avatar
    HansVogelaar
    May 15, 2022

    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
  • HansVogelaar's avatar
    HansVogelaar
    MVP
    May 15, 2022

    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
    • JoAvg's avatar
      JoAvg
      Brass Contributor
      May 15, 2022

      HansVogelaar 

       

      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.

      • HansVogelaar's avatar
        HansVogelaar
        MVP
        May 15, 2022

        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
    • JoAvg's avatar
      JoAvg
      Brass Contributor
      May 15, 2022
      These worked both like a charm.
      Thank you a ton!!!
  • HansVogelaar's avatar
    HansVogelaar
    MVP
    May 15, 2022

    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

Resources