Split multiple workbooks

Deepak · Dec 2, 2015

Hi,

If not urgent, Would to like to have some delay as i am quiet busy & will post the update asap.

ajoshi76 · Dec 2, 2015

Its kinda urgent. But understand your situation.

Deepak · Dec 2, 2015

ajoshi76 said:
Its kinda urgent. But understand your situation.

Ok.Check @ eve

ajoshi76 · Dec 2, 2015

Great. Thank you Deepak. Appreciate

Deepak · Dec 2, 2015

Check it...

Code:

Option Explicit
Sub Split_Multiple_Sheets_in_A_Workbook_v2()
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
                If Not InStr(1, "OverviewReferences", ws.Name) > 0 Then
                    ws.UsedRange.AutoFilter col_filter, UListValue
                    With N
                        ws.AutoFilter.Range.Copy
                        .Sheets.Add().Name = ws.Name
                        .Sheets(ws.Name).Paste
                        ActiveSheet.Cells.EntireColumn.AutoFit
                    End With
                    ws.AutoFilterMode = False
                End If
            Next
'========================================================================
          ThisWorkbook.Sheets("References").Copy Before:=N.Sheets(1)
          ThisWorkbook.Sheets("Overview").Copy Before:=N.Sheets(1)
'========================================================================
          'Delete Empty Sheets
          For Each ws In N.Sheets
                If Not InStr(1, "OverviewReferences", ws.Name) > 0 Then
                    If IsEmpty(ws.UsedRange) Then ws.Delete
                End If
            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

ajoshi76 · Dec 2, 2015

"AlphaNumericOnly"
Compile error: Sub or Function not defined

ajoshi76 · Dec 2, 2015

Got it. I didnt use the code for AlphanumericOnly ... Let me check and revert how the code works.

Deepak · Dec 2, 2015

You haven't copied the UDF thus error occurred.

check it.

Code:

Option Explicit
Sub Split_Multiple_Sheets_in_A_Workbook_v2()
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
                If Not InStr(1, "OverviewReferences", ws.Name) > 0 Then
                    ws.UsedRange.AutoFilter col_filter, UListValue
                    With N
                        ws.AutoFilter.Range.Copy
                        .Sheets.Add().Name = ws.Name
                        .Sheets(ws.Name).Paste
                        ActiveSheet.Cells.EntireColumn.AutoFit
                    End With
                    ws.AutoFilterMode = False
                End If
            Next
'========================================================================
          ThisWorkbook.Sheets("References").Copy Before:=N.Sheets(1)
          ThisWorkbook.Sheets("Overview").Copy Before:=N.Sheets(1)
'========================================================================
          'Delete Empty Sheets
          For Each ws In N.Sheets
                If Not InStr(1, "OverviewReferences", ws.Name) > 0 Then
                    If IsEmpty(ws.UsedRange) Then ws.Delete
                End If
            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

' this will exclude non AlphaNumericOnly from a string
Function AlphaNumericOnly(strSource As String) As String
    Dim i As Integer
    Dim strResult As String
    For i = 1 To Len(strSource)
        Select Case Asc(Mid(strSource, i, 1))
            Case 32, 48 To 57, 65 To 90, 97 To 122: 'include 32 if space needs to include
                strResult = strResult + Mid(strSource, i, 1)
        End Select
    Next
    AlphaNumericOnly = strResult
End Function

ajoshi76 · Dec 2, 2015

Got it. I didnt use the code for AlphanumericOnly ... Let me check and revert how the code works.

ajoshi76 · Dec 2, 2015

Quick : My Column filter is on D4. Hence, it doesnt let the code go ahead

Deepak · Dec 2, 2015

ajoshi76 said:
Quick : My Column filter is on D4. Hence, it doesnt let the code go ahead

Remove the filter

ajoshi76 · Dec 2, 2015

What i meant was that we have a line of code stating :

col_filter = 4

It take D1 as the filter to cut the data.... but the column header is on D4. Hence, the col_filter should consider D4 and not just column 4.

ajoshi76 · Dec 2, 2015

The code goes to DONE DONE DONE without doing anything

ajoshi76 · Dec 2, 2015

After having run the code multiple times i know what the functionality of the code.

Workbook Details:

The workbook has 5 sheets:

Overview
Stats
Estate
Milestone
References

The workbook has lot of macros other than the one we are currently wanting to create.

Worksheet Details:

Estate and Milestone header row is Row No. 4
Both the sheet has lot of formulas in multiple columns referencing each other and the References sheet.

Macro Functionality expected:

The macro should be able to split the workbook into multiple workbooks based on Column Filter 4 (using row header on Row No. 4)
The Overview, Stats and References sheets should not be split but copied as it is
The formulas should not be broken and should be referencing the sheets within the same workbook not the original workbook from which the split happened
Macros should not be broken as there would be button on the Overview page

Deepak · Dec 2, 2015

Pls share the sample workbook!

Deepak · Dec 2, 2015

ajoshi76 said:
What i meant was that we have a line of code stating :

col_filter = 4

It take D1 as the filter to cut the data.... but the column header is on D4. Hence, the col_filter should consider D4 and not just column 4.

You haven't said the same earlier.

Deepak · Dec 2, 2015

ajoshi76 said:
The code goes to DONE DONE DONE without doing anything

As it takes unique from col 2 [col_filter = 2]

ajoshi76 · Dec 2, 2015

Yes, understand that it takes column 2. i have changed in to column 4 but still it goes to DONE DONE DONE without splitting the workbooks

ajoshi76 · Dec 2, 2015

I am unable to send the sample workbook as its against my company's legal policies. I will try and do something from home and upload.

Deepak · Dec 2, 2015

ajoshi76 said:
Yes, understand that it takes column 2. i have changed in to column 4 but still it goes to DONE DONE DONE without splitting the workbooks

because! col 4 has same dates....

Deepak · Dec 2, 2015

ajoshi76 said:
I am unable to send the sample workbook as its against my company's legal policies. I will try and do something from home and upload.

sure!!

ajoshi76 · Mar 18, 2017

Hello

I am attaching the source file and the final files i get after the macro is played.
Book1 is the source file which has the macro. M1 to M4 is the split workbooks based on the macro. Couldn't attach the remaining created by the macro.

1. I dont want to lose any formatting in Consolidated sheet
2. I want formulas to remain formulas in the split M1 to M4 workbooks
3. All other sheets in the Book1 except Consolidated should be copied as it is in the Split workbooks and not split as per Col 4 as mentioned in the macro

Can someone help
Regards
Ashish

Deepak · Mar 18, 2017

Hi

You have just taken a decade to arrange a sample copy from office to home...

Not an issue....

I will take care on Monday.

ajoshi76 · Mar 19, 2017

thanks deepak; appreciate your help.

Split multiple workbooks

Excel Ninja

Member

Excel Ninja

Member

Excel Ninja

Member

Member

Excel Ninja

Member

Member

Excel Ninja

Member

Member

Member

Excel Ninja

Excel Ninja

Excel Ninja

Member

Member

Excel Ninja

Excel Ninja

Member

Attachments

Excel Ninja

Member