Page 1 of 2 1 2 LastLast
Results 1 to 10 of 20

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

  1. #1

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



    Register for a FREE account, and/
    or Log in to avoid these ads!

    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 by balla506; 2013-06-13 at 04:40 PM.

  2. #2
    Conjurer royUK's Avatar
    Join Date
    Mar 2011
    Location
    Derbyshire, UK
    Posts
    155
    Articles
    0
    Excel Version
    most versions
    I think that you could maybe design a better spreadsheet that stored all the data and then have a Pivottable for viewing by regions.
    Hope that helps

    Roy

  3. #3
    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.

  4. #4
    Conjurer royUK's Avatar
    Join Date
    Mar 2011
    Location
    Derbyshire, UK
    Posts
    155
    Articles
    0
    Excel Version
    most versions
    Hope that helps

    Roy

  5. #5
    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.

  6. #6
    Magician NoS's Avatar
    Join Date
    Jan 2013
    Location
    British Columbia
    Posts
    719
    Articles
    0
    Excel Version
    Excel 2010 64bit
    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

  7. #7
    Magician NoS's Avatar
    Join Date
    Jan 2013
    Location
    British Columbia
    Posts
    719
    Articles
    0
    Excel Version
    Excel 2010 64bit
    Sorry, too late to edit last post. I missed a bunch of stuff in your description. Best disregard my previous post.
    Last edited by NoS; 2013-06-14 at 02:10 AM.

  8. #8
    Conjurer royUK's Avatar
    Join Date
    Mar 2011
    Location
    Derbyshire, UK
    Posts
    155
    Articles
    0
    Excel Version
    most versions
    I don't think you will get many takers on this one without providing sample workbooks.
    Hope that helps

    Roy

  9. #9
    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.

    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

  10. #10
    Magician NoS's Avatar
    Join Date
    Jan 2013
    Location
    British Columbia
    Posts
    719
    Articles
    0
    Excel Version
    Excel 2010 64bit
    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

Page 1 of 2 1 2 LastLast

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •