Create Subfiles from a master file using key to split workbooks to seperate files

B

balla506

New member
Joined
Jun 13, 2013
Messages
9
Reaction score
0
Points
0
Hi,


I am trying to make my macro more dynamic for a spreadsheet I am working on. I have this code which splits out worksheets (using the specific names of the worksheets-not dynamic) from a main workbook into template workbooks (which are basically just an empty workbook because I didn't know how else to do it) and then saves them using the paths below. I would like to make this more dynamic by splitting the different worksheets into new workbooks based on a key column in the hierarchy worksheet. Basically I have a list of accounts in column B with the file name they should be exported to in column A. There are about 30 accounts being split into 6 different region files. Also note that the same account might be listed multiple times in column A (needed to add multiple numbers for other lookup formulas in the worksheets) but that account worksheet will still only be going to one of the six region files and not to multiple regions. After these are copied to an individual file I would like to save it to a location on my computer. All files will go to this location. Any help on this is much appreciated. Thanks.
Code: 
Sub Create_Subfiles()



    Dim FDName           As String
    Dim FBName           As String
    Dim DIName           As String
    Dim WName           As String
    Dim FPath           As String
    Dim BWName          As String
    
    'File names and directory path
    FDName = Workbooks("Sales Forecast Template.xlsm").Sheets("Hierarchy").Range("f14").Value
    FBName = Workbooks("Sales Forecast Template.xlsm").Sheets("Hierarchy").Range("f13").Value
    DIName = Workbooks("Sales Forecast Template.xlsm").Sheets("Hierarchy").Range("f15").Value
    WName = Workbooks("Sales Forecast Template.xlsm").Sheets("Hierarchy").Range("f12").Value
    TOTName = Workbooks("Sales Forecast Template.xlsm").Sheets("Hierarchy").Range("f16").Value
    FPath = "C:/desktop"
   
    
    
    
    
    
    




    
    
    
    'open template files
    Workbooks.Open Filename:= _
        "P:\Sales\SalesFinance\Sales Forecast\Template\Template Files\1.xlsm"
    Workbooks.Open Filename:= _
        "P:\Sales\SalesFinance\Sales Forecast\Template\Template Files\2.xlsm"
    Workbooks.Open Filename:= _
        "P:\Sales\SalesFinance\Sales Forecast\Template\Template Files\3.xlsm"
    Workbooks.Open Filename:= _
        "P:\Sales\SalesFinance\Sales Forecast\Template\Template Files\4.xlsm"
    Workbooks.Open Filename:= _
        "P:\Sales\SalesFinance\Sales Forecast\Template\Template Files\Total.xlsm"
    Windows("Sales Forecast Template.xlsm").Activate




    'move worksheets to proper workbooks and save them to correct directory
    Sheets(Array("Sheet1", "Sheet 2").Sheets(1)
    Sheets(Array("Hierarchy", "Couponing", "Sheet1")).Select
    Sheets("Sheet1").Activate
    ActiveWindow.SelectedSheets.Visible = False
    Range("A2").Select
    ActiveWorkbook.SaveAs Filename:=FPath & "\" & FDName, FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    ActiveWorkbook.Close False
    Windows("Sales Forecast Template.xlsm").Activate
    
    Sheets(Array("Sheet 5", "Sheet 7").Sheets(1)
    Sheets(Array("Hierarchy", "Couponing", "Sheet1")).Select
    Sheets("Sheet1").Activate
    ActiveWindow.SelectedSheets.Visible = False
    Range("A2").Select
    ActiveWorkbook.SaveAs Filename:=FPath & "\" & FBName, FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    ActiveWorkbook.Close False
    Windows("Sales Forecast Template.xlsm").Activate
















ThisWorkbook.Close False
End Sub
 
Last edited:
I think that you could maybe design a better spreadsheet that stored all the data and then have a Pivottable for viewing by regions.
 
The purpose for this is spreadsheet is to have master workbook with all the account worksheets. Based on the key worksheet these are split into separate files for security purposes because regions are not supposed to see each other. They actual worksheets cannot be changed. This is the reason I have to do it this way.
 
Roy- Thanks for the info. Makes sense and I will not do that again. I'll update the others too.

FYI-I've posted this on a couple of different forums here but cannot post links due to number of posts. Posted to OZGrid, Mr Excel, and VBA express. I will update if any sites give any info. To date I have had no answers so far. Thanks for the help on this.
 
maybe try something along the lines of this

Code: 
Option Explicit

Sub Create_Subfiles()

    Dim FDName As String
    'etc.
    Dim FPath  As String
    
'File names from Hierarchy
    With ThisWorkbook.Sheets("Hierarchy")
        FDName = .Range("f14").Value
        'etc.
    End With
    
'Folder to save in
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        FPath = .SelectedItems(1)
    End With

'Create and save Workbooks
    Sheets(Array("Hierarchy", "Couponing", "Sheet1")).Copy
        With ActiveWorkbook
            .SaveAs Filename:=FPath & "\" & FDName, FileFormat:= _
            xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
            .Close SaveChanges:=True
        End With
 'etc.
 
End Sub
 
Sorry, too late to edit last post. I missed a bunch of stuff in your description. Best disregard my previous post.
 
Last edited:
Ok, I have continued to try to create something to help me on this. I have come up with the code shown below but am getting a compile error saying else without if which is not making any sense to me. I have also attached a sample document for reference.

View attachment Scorecarding Template.xlsm

Code: 
Sub Createsubfiles()

Dim bottomF As Long, rngUniques As Range, c As Range


'set calc to manual to save time
    
Application.Calculation = xlCalculationManual


'finds unique values in Name column


bottomF = Range("F" & Rows.Count).End(xlUp).Row
Range("F1:F" & bottomF).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUniques = Range("F2:F" & bottomF).SpecialCells(xlCellTypeVisible)
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData


'create sub files


Workbooks.Add
ActiveWorkbook.SaveAs ("C:\" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N2") & "\" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N5") & "/" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N5") & " FY" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N2") & " - " & "East.xlsx")
Workbooks.Add
ActiveWorkbook.SaveAs ("C:\" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N2") & "\" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N5") & "/" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N5") & " FY" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N2") & " - " & "Southeast.xlsx")
Workbooks.Add
ActiveWorkbook.SaveAs ("C:\" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N2") & "\" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N5") & "/" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N5") & " FY" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N2") & " - " & "West A.xlsx")
Workbooks.Add
ActiveWorkbook.SaveAs ("C:\" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N2") & "\" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N5") & "/" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N5") & " FY" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N2") & " - " & "West B.xlsx")
Workbooks.Add
ActiveWorkbook.SaveAs ("C:\" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N2") & "\" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N5") & "/" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N5") & " FY" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N2") & " - " & "Central A.xlsx")
Workbooks.Add
ActiveWorkbook.SaveAs ("C:\" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N2") & "\" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N5") & "/" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N5") & " FY" & Workbooks("Scorecarding Template.xlsm").Sheets("Reference").Range("N2") & " - " & "Central B.xlsx")




'moves acct to proper file


For Each c In rngUniques


If c.Offset(, -1).Value = "East" Then Sheets(c.Value).Move After:=Workbooks("Q3 FY1213 - East").Sheets(1)


ElseIf c.Offset(, -1).Value = "Southeast" Then Sheets(c.Value).Move After:=Workbooks("Q3 FY1213 - Southeast").Sheets(1)


ElseIf c.Offset(, -1).Value = "West A" Then Sheets(c.Value).Move After:=Workbooks("Q3 FY1213 - West A").Sheets(1)


ElseIf c.Offset(, -1).Value = "West B" Then Sheets(c.Value).Move After:=Workbooks("Q3 FY1213 - West B").Sheets(1)


ElseIf c.Offset(, -1).Value = "Central A" Then Sheets(c.Value).Move After:=Workbooks("Q3 FY1213 - Central A").Sheets(1)


ElseIf c.Offset(, -1).Value = "Central B" Then Sheets(c.Value).Move After:=Workbooks("Q3 FY1213 - Central B").Sheets(1)




End If




Next c








Application.Calculation = xlCalculationAutomatic
End Sub
 
balla506,

Put this code in a module of the workbook you posted and I think you'll find it does what you are after.

I commented out the file path and used something that made more sense on my computer. Also commented out the move of the sheets and used copy so that the workbook is not depleted when testing further. There is no error checking or any thing included to look out for non-existent sheets or invalid file paths or such.

Don't know why you were trying to obtain uniqueness in the Name column, Excel wouldn't allow anything but unique sheet names.
I've used the File Location column which I take to be the workbook names.

You don't have to add a new workbook and then add sheets to it one at a time, .move or .copy will do that and you need to supply the saveas path and file name.

At any rate, have a look and if you can adapt it, that's good. If not maybe somebody else will be along with suggestions.

Good Luck with your project
NoS


Code: 
Option Explicit

Sub MoveSheetsToFiles()

    Dim d As Object, c As Range, k, tmp As String
    
    Dim rng As Range
    Dim cel As Range
    Dim WBname As String
    Dim shtArraystring As String
    
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    Set rng = Sheets("Reference").Range("E2:E" & Range("E" & Rows.Count).End(xlUp).Row)
    
    Set d = CreateObject("scripting.dictionary")
    
    For Each c In rng
        tmp = Trim(c.Value)
        If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
    Next c
'array of unique workbooks is now in memory
    
    For Each k In d.keys
        'get a workbook name
        With ThisWorkbook.Sheets("Reference")
            'WBname = "C:\" & .Range("N2") & "\" & .Range("N5") & "/" & .Range("N5") & " FY" & .Range("N2") & " - " & k & ".xlsx"
            WBname = "D:\Junk\" & k & ".xlsx"
        End With
        
        'get the sheet names associated with this workbook
        For Each cel In rng
            If cel.Value = k Then
                shtArraystring = shtArraystring & cel.Offset(0, 1).Value & "|"
            End If
        Next cel

        'remove last |
        shtArraystring = Left(shtArraystring, Len(shtArraystring) - 1)
        
'Create and save Workbooks
'need to split the string into an array

    'Sheets(Split(shtArraystring, "|")).Move
    Sheets(Split(shtArraystring, "|")).Copy
        With ActiveWorkbook
            .SaveAs Filename:=WBname, FileFormat:=51, CreateBackup:=False
            .Close SaveChanges:=True
        End With

'clear variables for next go round
    WBname = ""
    shtArraystring = ""
        
    Next k

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

End Sub
 
The uniqueness was there for an account being listed in column F multiple times even though it was going to the same end file (ex "Acct 2" listed in cell F2 and F3 both going to the "East" file). I thought this would create an error if it tried to move it twice but it already existed with the same name. I should have put an example of this in the cleaned spreadsheet I posted. Sorry about that. This works beautifully. While I can follow the code and appreciate it this is well beyond my knowledge of coding VBA but is awesome. Thank you so much for your help on this.
 
I used the test file to test this. For some reason on my file with the actual accounts this is not working and I am erroring out on the copy line and then later when I try to run the macro it doesn't do anything. Could this be because I have ' - and () in sheet names. Any help on this would be wonderful. Thanks.
 
Could this be because I have ' - and () in sheet names.
Click to expand...
The file you posted doesn't have this.

I would suspect a problem with your path and/or file names for the new workbooks.... but then the error would be on the .SaveAs line after the new workbook was already created and still showing as Book1.
 
If you are trying this on another file, and a sheet name contains the same character that is being used as the delimiter the split function is looking for, that would create a problem on the copy line. In this case the "|".
 
I am not using this bar on any of the sheet names. And the line that is the issue is the Copy line and I get the Method 'copy of object Sheets' failed. I tried just leaving it go into a Junk folder on my main drive like you so the error is in the actual move of the worksheets. It never gets to the save the file portion and no files are created in the folder. Any ideas why this would be? Thanks for your help again.
 
I'm not having any success trying to duplicate that error.
Could you possibly post the workbook you're using when this is happening?
 
Here it is. I modified very slightly and just regular characters. It does cause the error I've been getting. Thanks.
 

Attachments

  • Scorecarding Template.xlsm
    86.1 KB · Views: 18
Thank you, now see what's happening. Guess this comes under that no error checking disclaimer.
The error is caused by sheet names more than once on the copy line.

Try changing this
Code: 
        'get the sheet names associated with this workbook
        For Each cel In rng
            If cel.Value = k Then
                shtArraystring = shtArraystring & cel.Offset(0, 1).Value & "|"
            End If
        Next cel
to this
Code: 
        'get the sheet names associated with this workbook
        For Each cel In rng
            If cel.Value = k Then
                'if shtArraystring is empty then add this
                If Len(shtArraystring) = 0 Then
                    shtArraystring = shtArraystring & cel.Offset(0, 1).Value & "|"
                Else    'check if this is already added
                    If InStr(1, shtArraystring, cel.Offset(0, 1).Value, vbTextCompare) = 0 Then
                        'doesn't exist so add it
                        shtArraystring = shtArraystring & cel.Offset(0, 1).Value & "|"
                    End If
                End If
            End If
        Next cel
 
This fixes the problem. Thanks for your help on this works beautifully.
 
You must log in or register to reply here.
Back
Top