Macro to save as and create new folder named after the contents of a cell

[Deekappa]

Hi all

I don't have much experience with VBA, but I've been able to find most formulas I want with a quick search, and some slight modification. I'm a bit stuck on this one though.

I have a section of code below, which creates a new workbook based off an excel template, and saves it as a new workbook named after a cell.

What I would like it to also do, is to create a new folder (named after a cell in the original workbook which contains the macro) and save the new workbook in that folder. So every time the macro is clicked, a new workbook and subfolder is created, within my quotes folder. Hopefully that makes sense.

' Create new job template
    Dim wB As Workbook
    Dim nPath As String
    nPath = "I:\Mark B\New Job Template Resources\Quotes\" & ThisWorkbook.Sheets("Leads").Range("B23").Value
    Set wB = Workbooks.Add("I:\Mark B\New Job Template Resources\Custom Office Templates\Job Template.xltm")
    With wB
        .SaveAs Filename:=nPath & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
    
    End With

Thanks in advance for the help, these forums are great.

 

[Yongle]

Try something along these lines
-amend to point at correct workbook, sheet and cells

    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim qPath As String, fPath As String, sFolder As String, fName As String

    qPath = "I:\Mark B\New Job Template Resources\Quotes"
    sFolder = Range("A1").Value         'qualify with workbook & sheet
    fPath = qPath & "\" & sFolder
[COLOR=#696969][I] 'create subfolder   [/I][/COLOR]
    If Len(Dir(fPath, vbDirectory)) = 0 Then MkDir fPath
[I][COLOR=#696969] 'save file to that folder[/COLOR][/I]
    fName = Range("A2").Value           'qualify with workbook & sheet
    wb.SaveAs Filename:=fPath & "\" & fName & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled

 

[Deekappa]

Thank you! Finished product below, worked perfectly.

        ' Create new job template
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim qPath As String, fPath As String, sFolder As String, fName As String


    qPath = "I:\Mark B\New Job Template Resources\Quotes"
    sFolder = Range("B23").Value
    fPath = qPath & "\" & sFolder
 'create subfolder
    If Len(Dir(fPath, vbDirectory)) = 0 Then MkDir fPath
 'save file to that folder
    fName = Range("B23").Value
    Set wb = Workbooks.Add("I:\Mark B\New Job Template Resources\Custom Office Templates\Job Template.xltm")
    wb.SaveAs Filename:=fPath & "\" & fName & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled

 

[Yongle]

Glad it is working for you. Some observations (may not matter, but best to be aware)

Range("B53") is not qualified with workbook or worksheet reference
- wb is initially ThisWorkbook so possibly wb.Sheets("Leads").Range("B53")

fName = sFolder would avoid going to the worksheet twice for same value (slightly faster)