• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Split multiple workbooks

ajoshi76

ajoshi76

Member
I have a workbook called "WB1.xlsx" which has multiple worksheets "WS1", "WS2" and "WS3".

Each worksheet has a common column called "Name"....
I am looking for a macro to split the data using the Name column into multiple workbooks.

The output should look like:

WB1: Master Workbook having WS1, WS2 and WS3 (no splits)

WB2: Sheets WS1, WS2 and WS3 having data for only Resource 1
WB3: Sheets WS1, WS2 and WS3 having data for only Resource 2
WB4: Sheets WS1, WS2 and WS3 having data for only Resource 3

Till the last Resource available in WB1.


Thanks for helping in advance

Regards
Ashish
 
The code didnt split. It asked me for the column for filter but didnt do anything beyond that. What could have been possibly wrong.
 
Good news... The code split one worksheet into multiple workbooks.
But the requirement is to have all worksheets split based on a single column in each worksheet
 
OK thanks. I tried running the macro, what it did was took the active sheet and split it via the column selected. but it doesnt do anything for the other worksheets.

What the macro should do is:

1. Active sheet split into multiple workbooks based on the selected columns
2. goto sheet 2 of the master select the same filters and add the data into sheet 2 of the existing workbook (newly created by that name).
3. goto sheet 3 of the master workbook and repeat the same step.
 
Expected is:

WB1: Master Workbook having WS1, WS2 and WS3 (no splits)

WB2: Sheets WS1, WS2 and WS3 having data for only Resource 1
WB3: Sheets WS1, WS2 and WS3 having data for only Resource 2
WB4: Sheets WS1, WS2 and WS3 having data for only Resource 3

Till the last Resource available in WB1.
 
Hi,

Check this...


Code: 
Option Explicit
Sub Split_Multiple_Sheets_in_A_Workbook_v1()
Dim ws As Worksheet, MyRange As Range, i As Long, N As Workbook
Dim UList As Collection, UListValue As Variant, myPath As String, myFileName As String
   
Application.ScreenUpdating = False
Application.DisplayAlerts = False

myPath = Application.ThisWorkbook.Path & "\"

'--------------------------------------------------------------------------
'Make a carbon copy of the workbook
myFileName = Format(Now, "d_m_yyyy_h_m_s") & "_" & Application.ThisWorkbook.Name
ThisWorkbook.SaveCopyAs myPath & myFileName
'--------------------------------------------------------------------------

'From where to find filter criteria
Set MyRange = Sheets("App Level").UsedRange

'------------------------------------------------------------------------
    'Make a collection of unique value of APP ID
    Set UList = New Collection
        On Error Resume Next
            For i = 2 To MyRange.Rows.Count
                UList.Add MyRange.Cells(i, 1), CStr(MyRange.Cells(i, 1))
            Next
        On Error GoTo 0
'------------------------------------------------------------------------

'========================================================================
    'Strat loop with unique collection
    For Each UListValue In UList
        Set N = Workbooks.Add(xlWBATWorksheet)
            For Each ws In ThisWorkbook.Sheets
                ws.UsedRange.AutoFilter 1, UListValue
                With N
                    ws.AutoFilter.Range.Copy
                    Sheets.Add().Name = ws.Name
                    Sheets(ws.Name).Paste
                    Cells.EntireColumn.AutoFit
                End With
                ws.AutoFilterMode = False
            Next
'========================================================================
           
'========================================================================
            'Delete Empty Sheets
            For Each ws In N.Sheets
                If IsEmpty(ws.UsedRange) Then ws.Delete
            Next
'========================================================================
           
'=================================================================================
            'Save the created workbook
            N.SaveAs myPath & AlphaNumericOnly(UListValue.Value)
            N.Close False
'=================================================================================
    Next

MsgBox "DONE-DONE-DONE", vbInformation

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
 
If the column of the Unique value changes, where do i update the code. I made one column change and the code failed. Can you help.
 

Attachments

  • Book1.xlsm
    30.6 KB · Views: 3
i know the issue, the code that has been provided uses 1st column as unique value filter. But what if my 2nd column or 3rd column is the unique value which needs auto filter.

I would like to thank you very much for this amazing code. One small thing in this code will make it great for me.
 
That's why earlier made it with input box but u failed to understand.
Not an issue so far.

In below line change 1 to what column want to filter as unique.

ws.UsedRange.AutoFilter 1, UListValue


Let me know if u wish to make it dynamic by input box or by some other method based criteria.
 
After changing the 1 to 2. The macro didnt paste the data in the new workbooks. Uploading the document.
 

Attachments

  • Book1.xlsm
    30.9 KB · Views: 8
Remaining Documents (created using macro).
 

Attachments

  • 14_7_2015_23_52_22_Book1.xlsm
    30.9 KB · Views: 4
  • DRBJAURN0000183A H Communication.xlsx
    9.4 KB · Views: 1
  • DRBJBUXA0000955Ayush Enterprise.xlsx
    9.4 KB · Views: 2
Oh..again sorry that i didn't brief properly.

Check this...


Code: 
Option Explicit
Sub Split_Multiple_Sheets_in_A_Workbook_v1()
Dim ws As Worksheet, MyRange As Range, i As Long, N As Workbook
Dim UList As Collection, UListValue As Variant, myPath As String, myFileName As String
Dim col_filter As Integer

Application.ScreenUpdating = False
Application.DisplayAlerts = False


'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Either this...
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'col_filter = Application.InputBox("Which Col to filter")
'If Not col_filter <> False Then Exit Sub
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

'or
col_filter = 2
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

myPath = Application.ThisWorkbook.Path & "\"

'--------------------------------------------------------------------------
'Make a carbon copy of the workbook
myFileName = Format(Now, "d_m_yyyy_h_m_s") & "_" & Application.ThisWorkbook.Name
ThisWorkbook.SaveCopyAs myPath & myFileName
'--------------------------------------------------------------------------

'From where to find filter criteria
Set MyRange = Sheets("App Level").UsedRange


'------------------------------------------------------------------------
    'Make a collection of unique value of APP ID
    Set UList = New Collection
        On Error Resume Next
            For i = 2 To MyRange.Rows.Count
                UList.Add MyRange.Cells(i, col_filter), CStr(MyRange.Cells(i, col_filter))
            Next
        On Error GoTo 0
'------------------------------------------------------------------------

'========================================================================
    'Strat loop with unique collection
    For Each UListValue In UList
        Set N = Workbooks.Add(xlWBATWorksheet)
            For Each ws In ThisWorkbook.Sheets
                ws.UsedRange.AutoFilter col_filter, UListValue
                With N
                    ws.AutoFilter.Range.Copy
                    Sheets.Add().Name = ws.Name
                    Sheets(ws.Name).Paste
                    Cells.EntireColumn.AutoFit
                End With
                ws.AutoFilterMode = False
            Next
'========================================================================
           
'========================================================================
            'Delete Empty Sheets
            For Each ws In N.Sheets
                If IsEmpty(ws.UsedRange) Then ws.Delete
            Next
'========================================================================
           
'=================================================================================
            'Save the created workbook
            N.SaveAs myPath & AlphaNumericOnly(UListValue.Value)
            N.Close False
'=================================================================================
    Next

MsgBox "DONE-DONE-DONE", vbInformation

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
 
Awesome code. :) it does the job. But we lost the save functionality.
Now all excels are open with data and it doesnt save it in the location. :(
 
Further to the macro that was provided which works like a charm when all sheets needs to be split.

I have a small modification request..... Attached is a new excel having 2 additional sheets "Overview" and "References".

When the macro works. It should split the remaining 3 sheets as per what the macro does but the remaining 2 sheets Overview and References should be fully copied into every workbook (per split).
 

Attachments

  • Book1 (1).xlsm
    27.1 KB · Views: 8
The output should be :

1. Overview sheet (Full copied in every workbook)
2. References sheet (Full copied in every workbook)
3. App Level (Split in multiple workbooks per Column B values)
4. Environment Level ((Split in multiple workbooks per Column B values)
5. Milestone Level (Split in multiple workbooks per Column B values)


So if there are 4 different Unique Values in Column B the macro should create 4 workbooks (which is done by the vba code in this thread) with the except of having the 2 additional sheets (which should be copied in every workbook.
 
You must log in or register to reply here.
Back
Top