Split a Master Workbook into multiple workbooks

[Vivek D]

I have a master dashboard that has been generated using the entire company's sales data (all business units).
I need to create multiple workbooks from this master for each business unit with only their data.

My requirement is similar to what's discussed here
http://chandoo.org/forum/threads/split-multiple-workbooks.24480/#post-147414

However, a few reasons why I wasn't able to use the solution mentioned in that are:-
1. My master workbook is a full dashboard having a lot of pivots, charts etc.
2. The data is an excel table in a sheet. However, there is some content on top of that excel table as well.
3. I need rows deleted rather than copied.

What I need to do is this through VBA:-

Have a separate file called say "Dashboard Splitter.xlsx" (I can put all the BU names in a list on this one if required) with a Macro that does the following:-
1. Take the Master Dashboard file
2. For each BU (BU is the first column in the data table in the Master Dashboard)
2a. Make a copy of the Excel file with BU Name as prefix
In the new excel file...
2b. Clear filter if any on the data table
2c. Select all rows in the data table except the ones for the selected BU
2d. Delete those rows
2e. Refresh the Pivots
1. Repeat steps 1 & 2 for next BU until all BUs are done

In the end I should have a dashboard for each of the BUs with just their data.

Attached is a sample file.

 

[Luke M]

Hi Vivek,

I was able to slightly modify Ron's code from here:
http://www.rondebruin.nl/win/s3/win006_4.htm

to get something that should work. Loops through each unique item in the table copies it to the template file (make sure you change this in the code), refreshed the pivots, save and close.

 

[Vivek D]

Thanks Luke.

Can it be done the way I described though i.e. delete unwanted rows instead of copying the one that are required. Also wonder if the 8196 cells limitation for copying that the code indicates will be a problem. I will have a lot of data in the details sheet.

Also, the data and template will be in the same file like in the sample. I just created a very simplistic example but imagine that there are multiple charts, pivots and shapes etc in the Dashboard sheet and all the data (for all BUs) is in the details sheet.

When I do it manually, I do it the way I described

1. Create the master dashboard with all the data (The data into the master comes through Power query so it's basically like clicking a button to refresh).

2. Once I have that ready...
I create a copy of the file, delete the unwanted rows (i.e. rows for other BUs) and refresh pivot. Repeat this step for each BU.

I want to do this part through VBA.

 

[Luke M]

A) Why would we copy over all the data and remove the unwanted vs. just copying what we want? This seems like an extra step, and is much more complicated

B) the 8196 limit is not number of cells, but number of different areas. So, if the data is completely randomized, it could be an issue...if you run into it, we would want to sort the data first before executing macro

To automate your current method, you'd have to create a copy, open the copy, remove rows. Create another copy, open copy, remove rows, etc.
Would be better to create a copy of your current tool, delete/clear all the input data that is in there, and call this your template. Then, the macro I wrote will copy in the needed information.

 

[Vivek D]

My bad. I kind of assumed, deleting would be a better option that copying.

What you suggested in the end would work too but would like that part done through code (automated) instead of me having to maintain 2 files. Can you add in the code for that portion i.e. create a copy of the master file and delete the data from it (use this as the template) and then the rest of the code will take care of the creation of the other files.

Basically, want to maintain and refresh my master file whenever I need (this is taken care of) and then click a button and that would generate the remaining files.

 

[Luke M]

Gotcha. Ok, wrote a small macro that will first create the template file. THen main macro can open that template, make the copies. WHen it's all done, it cleans up and kills the template file it created at beginning.

Sub Copy_To_Workbooks()

    Dim My_Range As Range
    Dim FieldNum As Long
    Dim CalcMode As Long
    Dim ViewMode As Long
    Dim ws2 As Worksheet
    Dim Lrow As Long
    Dim cell As Range
    Dim CCount As Long
    Dim WBNew As Workbook
    Dim WSNew As Worksheet
    Dim ErrNum As Long
    Dim fName As String
    Dim tempName As String
   
    Call CreateTemplate
    tempName = ThisWorkbook.Path & "\" & tempFile & ".xlsx"
   

    'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
    'and the header of the first column, D is the last column in the filter range.
    'You can also add the sheet name to the code like this :
    'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
    'No need that the sheet is active then when you run the macro when you use this.
    Set My_Range = Worksheets("Details").ListObjects(1).Range
    My_Range.Parent.Select

    If ActiveWorkbook.ProtectStructure = True Or _
       My_Range.Parent.ProtectContents = True Then
        MsgBox "Sorry, not working when the workbook or worksheet is protected", _
               vbOKOnly, "Copy to new worksheet"
        Exit Sub
    End If

    'This example filters on the first column in the range(change the field if needed)
    'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
    FieldNum = 1

    'Turn off AutoFilter
    My_Range.Parent.AutoFilterMode = False

    'Change ScreenUpdating, Calculation, EnableEvents, ....
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    ActiveSheet.DisplayPageBreaks = False

    'Add a worksheet to copy the a unique list and add the CriteriaRange
    Set ws2 = Worksheets.Add

    With ws2
        'first we copy the Unique data from the filter field to ws2
        My_Range.Columns(FieldNum).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("A1"), Unique:=True

        'loop through the unique list in ws2 and filter/copy to a new sheet
        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In .Range("A2:A" & Lrow)

            'Filter the range
            My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
             Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")

            'Check if there are no more then 8192 areas(limit of areas)
            CCount = 0
            On Error Resume Next
            CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
                     .Areas(1).Cells.Count
            On Error GoTo 0
            If CCount = 0 Then
                MsgBox "There are more than 8192 areas for the value : " & cell.Value _
                     & vbNewLine & "It is not possible to copy the visible data." _
                     & vbNewLine & "Tip: Sort your data before you use this macro.", _
                       vbOKOnly, "Split in worksheets"
            Else
                '==============
                '***IMPORTANT***
                'This is where you would open a template file, if you want to go that route
                'Add a new workbook
                '==============
                If Dir(tempName) <> "" Then
                    Set WBNew = Workbooks.Open(tempName)
                    Set WSNew = WBNew.Worksheets("Details")
                Else
                    Set WBNew = Workbooks.Add
                    Set WSNew = WBNew.Worksheets(1)
                End If
               
                On Error Resume Next
                WSNew.Name = cell.Value
                If Err.Number > 0 Then
                    ErrNum = ErrNum + 1
                    WSNew.Name = "Error_" & Format(ErrNum, "0000")
                    Err.Clear
                End If
                On Error GoTo 0

                'Copy the visible data to the new worksheet
                My_Range.SpecialCells(xlCellTypeVisible).Copy
                'This is where you are pasting into. Change this if needed
                With WSNew.Range("A6")
                    ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                    ' Remove this line if you use Excel 97
                    .PasteSpecial Paste:=8
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                    .Select
                End With
            End If
           
            'REfresh pivot Tables in new workbook
            WBNew.RefreshAll
            'Create name for new file
            fName = ThisWorkbook.Path & "\" & cell.Value & "_Extract.xlsx"
            If Right(fName, 5) <> ".xlsx" Then
                fName = fName & ".xlsx"
            End If
           
            'Close and save
            Application.DisplayAlerts = False
            WBNew.Close SaveChanges:=True, Filename:=fName
            Application.DisplayAlerts = True

            'Show all data in the range
            My_Range.AutoFilter Field:=FieldNum

        Next cell

        'Delete the ws2 sheet
        On Error Resume Next
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

    End With

    'Turn off AutoFilter
    My_Range.Parent.AutoFilterMode = False

    If ErrNum > 0 Then
        MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
             & vbNewLine & "There are characters in the name that are not allowed" _
             & vbNewLine & "in a sheet name or the worksheet already exist."
    End If
    'Delete the template file
    Kill tempName

    'Restore ScreenUpdating, Calculation, EnableEvents, ....
    My_Range.Parent.Select
    ActiveWindow.View = ViewMode
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With

End Sub


Private Sub CreateTemplate()
Dim fPath As String
Dim fName As String
Dim tb As ListObject
Dim wbTemp As Workbook


fPath = ThisWorkbook.Path & "\"
fName = fPath & tempFile & ThisWorkbook.Name

'First, create a copy of the current book
ThisWorkbook.SaveCopyAs fName

'Open the temp file, to clear out table
Set wbTemp = Workbooks.Open(fName)

'Clear the table in template
Set tb = wbTemp.Worksheets("Details").ListObjects(1)

tb.DataBodyRange.Offset(1).Resize(tb.DataBodyRange.Rows.Count - 1).Delete
tb.DataBodyRange.ClearContents

'Remove VB code
Application.DisplayAlerts = False
wbTemp.SaveAs fPath & tempFile, 51
Application.DisplayAlerts = True
wbTemp.Close

'Delete the temp file with VB code
Kill fName

End Sub

 

[Vivek D]

Thanks a lot. Will incorporate into my dashboard and get back in case of any issues.