Save Excel Workbook into Created Folders

[Cherrie_01]

Hello,

I found a code that I would like to use to create a directory. In the each folder of the directory, I would like to save an excel file with the same name to the corresponding folder. The code creates a folder and file of my current workbook using the name listed in my reference cell however, I cannot get the code to work on a range of cells in excel. How can I get this code to work on a list of cells starting at A2? I don't have a defined range as this will be different for everyone that will be using this macro.

Any help would be greatly appreciated.

Here is the code that I am using:

Sub Macro1()
Dim strFilename, strDirname, strPathname, strDefpath As String
On Error Resume Next
strDirname = Range("A2").Value

strFilename = Range("A2").Value
strDefpath = Application.ActiveWorkbook.Path
If IsEmpty(strDirname) Then Exit Sub
If IsEmpty(strFilename) Then Exit Sub

MkDir strDefpath & "\" & strDirname
strPathname = strDefpath & "\" & strDirname & "\" & strFilename

ActiveWorkbook.SaveAs FileName:=strPathname & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub

 

[tonyyy]

Cherrie_01,

You might give the following a try...

Sub Macro1()
Dim strFilename, strDirname, strPathname, strDefpath As String
Dim r As Range
Dim LastRow As Long

'On Error Resume Next
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
strDefpath = Application.ActiveWorkbook.Path

For Each r In Range("A2:A" & LastRow)
    strDirname = r.Value
    strFilename = r.Value
    
    If IsEmpty(strDirname) Then Exit Sub
    If IsEmpty(strFilename) Then Exit Sub

    MkDir strDefpath & "\" & strDirname
    strPathname = strDefpath & "\" & strDirname & "\" & strFilename

    ActiveWorkbook.SaveAs Filename:=strPathname & ".xlsm", _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
Next r

MsgBox "Done!"
End Sub

Cheers,

tonyyy

 

[Cherrie_01]

Woozers, this saved me so much time. You're a life saver @tonyyy!!

 

[tonyyy]

Woozers? LOL!

Glad it worked out, Cherrie_01.