Creating folders/subfolders using Macro

[Gaura215]

Hello

I have a spreadsheet with approximately 10 tabs with different names (001, 002, 003....etc).
I am require to create an individual workbook for each spreadsheet, and save it in the month folder which will be created in another folder with the value mentioned in A1 of the active spreadsheet.

So my file path will look something like "D:\SpreadsheetName\2011\Month Name\" Month folder to be in the format of "YYMM"

I am require to create this whole path mark in red. It means, 3 folder to be created one inside another, and saving the workbook in the last created folder.

The name of the folder is mentioned in Range A1 of all spreadsheets, and the month is mentioned in Z65536 in the format "yymm". In that month folder I need to save that workbook created with a fixed file name, "107" in this case.

I have so many reports in which I need to do the same procedure. So, a condition should be there in the macro to search for this path before creating the path.

Please suggest me a code using which I can do this without putting in so much of my manual efforts.

Thanks in advance to all Macro Gurus.

 

[Comfy]

Thanks Darren was looking for a loop

Sub SheetSaver()

Dim xlSource As Workbook
Dim xlDest As Workbook
Dim xlSheet As Object
Dim DestPath As String
Dim mySheet As String
Dim myFolder As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

    Set xlSource = ActiveWorkbook
    
    For Each xlSheet In xlSource.Sheets
        mySheet = xlSheet.Range("A1").Value
        myFolder = xlSheet.Range("Z65536").Value
        DestPath = "D:\Documents and Settings\g.khanna\Desktop\107 Report\" & mySheet & "\2011\" & myFolder & "\Spreadsheet\"
        CreateFolder DestPath
        Set xlDest = Workbooks.Add
        xlSheet.Copy Before:=xlDest.Sheets(1)
        xlDest.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete
        xlDest.SaveAs (DestPath & xlSheet.Name & ".xls")
        xlDest.Close
        Set xlDest = Nothing
        Next
        
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub
'// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'// Procedure : CreateFolder | Sub
'// Author    : DarkSprout
'// Purpose   : Will Recursively Build ADirectory Tree
'// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub CreateFolder(Folder)
On Error Resume Next
Dim objFSO As Object: Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Folder <> "" Then
        If Not objFSO.FileExists(objFSO.GetParentFolderName(Folder)) Then
            Call CreateFolder(objFSO.GetParentFolderName(Folder))
        End If
        objFSO.CreateFolder (Folder)
    End If
End Sub

 

[Darren Bartrup]

Edit: You got it It doesn't loop - just keeps calling itself until the folder structure is built, so I guess the loop is the "Call CreateFolder" statement on line 6 of the procedure.

You might want to change your year - 2011 - to look at the year within cell Z65536?

 

[Gaura215]

Thanks a ton Comfy & Darren...this is working perfectly fine now.

I am really thankful to both of you.

 

[Sandcastor]

This code will build the folder structure:

'// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'// Procedure : CreateFolder | Sub
'// Author    : DarkSprout
'// Purpose   : Will Recursively Build ADirectory Tree
'// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub CreateFolder(Folder)
On Error Resume Next
Dim objFSO As Object: Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Folder <> "" Then
        If Not objFSO.FileExists(objFSO.GetParentFolderName(Folder)) Then
            Call CreateFolder(objFSO.GetParentFolderName(Folder))
        End If
        objFSO.CreateFolder (Folder)
    End If
End Sub

Thanks, Darren Bartrup That's an excellent solution. I love being able to search the board and find what I need. This actually mooted three other steps to my own dilemma.

Can you help with another aspect of the save? How can i easily force a file type save? Need to save as XLSM, but company wide excel default is XLSX.

haha, nevermind, fileFormat:=xlOpenXMLWorkbookMacroEnabled did the trick.

 

[VinuS]

This works only for value in cell A1.what if i want this to work from cell a1 to a100.
Please Reply asap.
Thanks in advance.

 

[Darren Bartrup]

Welcome to the board VinuS.

Maybe should've posted a new thread and added a link to this one - would show as 0 replies at first then so may have got a faster answer.

I haven't tested it, but something like:

Sub SheetSaver()

Dim xlSource As Workbook
Dim xlDest As Workbook
Dim xlSheet As Object
Dim DestPath As String
Dim mySheet As String
Dim myFolder As String
Dim x As Long




Application.ScreenUpdating = False
Application.DisplayAlerts = False


    Set xlSource = ActiveWorkbook
    
    For Each xlSheet In xlSource.Sheets
            For x = 1 To 100
            mySheet = xlSheet.Cells(x, 1).Value
            myFolder = xlSheet.Range("Z65536").Value
            DestPath = "D:\Documents and Settings\g.khanna\Desktop\107 Report\" & mySheet & "\2011\" & myFolder & "\Spreadsheet\"
            CreateFolder DestPath
            Set xlDest = Workbooks.Add
            xlSheet.Copy Before:=xlDest.Sheets(1)
            xlDest.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete
            xlDest.SaveAs (DestPath & xlSheet.Name & ".xls")
            xlDest.Close
            Set xlDest = Nothing
            Next x
        Next
        
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub
'// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'// Procedure : CreateFolder | Sub
'// Author    : DarkSprout
'// Purpose   : Will Recursively Build ADirectory Tree
'// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub CreateFolder(Folder)
On Error Resume Next
Dim objFSO As Object: Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Folder <> "" Then
        If Not objFSO.FileExists(objFSO.GetParentFolderName(Folder)) Then
            Call CreateFolder(objFSO.GetParentFolderName(Folder))
        End If
        objFSO.CreateFolder (Folder)
    End If
End Sub