Multiple sheet splitting

[sachin483]

i have a macro as below of splitting multiple sheets but after splitting the formatting gets changed and freeze column also not reflecting i want to keep formatting ,header,aliment and freezing as the main sheet can it is possible

The same has been posted in other forum as link below

http://www.excelfox.com/forum/showthrea ... -splitting" onclick="window.open(this.href);return false;
https://www.mrexcel.com/forum/excel-que ... tting.html" onclick="window.open(this.href);return false;

Code: Select all

Sub test()
    Dim ws As Worksheet, a, e, i As Long, ii As Long, w, wb As Workbook
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each ws In Worksheets
            a = Intersect(ws.Rows("3:" & Rows.Count), _
            ws.Range("a3").CurrentRegion).Value
            ReDim w(1 To UBound(a, 2))
            For i = 2 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
                End If
                If Not .Item(a(i, 1)).exists(ws.Name) Then
                    Set .Item(a(i, 1))(ws.Name) = _
                    CreateObject("System.Collections.ArrayList")
                    For ii = 1 To UBound(a, 2)
                        w(ii) = a(1, ii)
                    Next
                    .Item(a(i, 1))(ws.Name).Add w
                End If
                For ii = 1 To UBound(a, 2)
                    w(ii) = a(i, ii)
                Next
                .Item(a(i, 1))(ws.Name).Add w
            Next
        Next
        For Each e In .keys
            Set wb = Workbooks.Add
            For i = 0 To .Item(e).Count - 1
                If i + 1 > wb.Sheets.Count Then
                    wb.Sheets.Add after:=wb.Sheets(wb.Sheets.Count)
                    wb.Sheets(wb.Sheets.Count).Name = .Item(e).keys()(i)
                Else
                    wb.Sheets(i + 1).Name = .Item(e).keys()(i)
                End If
                w = Application.Index(.Item(e).items()(i).ToArray, 0, 0)
                wb.Sheets(.Item(e).keys()(i)).Cells(1) _
                .Resize(UBound(w, 1), UBound(w, 2)).Value = w
            Next
            wb.SaveAs ThisWorkbook.Path & "\" & e & ".xlsx"
            wb.Close
        Next
    End With
End Sub

[HansV]

Welcome to Eileen's Lounge!

I cannot run your code - the line

Code: Select all

                    Set .Item(a(i, 1))(ws.Name) = _
                    CreateObject("System.Collections.ArrayList")

produces an Automation Error. Could you post an example of the output produced by the macro, and also an example of the desired output?

[YasserKhalil]

Hello Mr. Hans
I think this error is related to using the .NET framework (update that if you are using old version)

[sachin483]

i am not getting the error i am using office 2010 , i want the same format as original file after splitting , kindly find attached output of the file and required

[sachin483]

please find enclosed attached output file

[HansV]

Hello Mr. Hans
I think this error is related to using the .NET framework (update that if you are using old version)

I don't have .NET Framework on my PC, and I prefer to keep it that way.

[HansV]

I have written a macro from scratch:

Code: Select all

Sub SplitData()
    Dim wbk As Workbook
    Dim wsh As Worksheet
    Dim r As Long
    Dim m As Long
    Dim col As New Collection
    Dim v As Variant
    Dim s As String
    On Error Resume Next
    For Each wsh In ThisWorkbook.Worksheets
        m = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
        For r = 4 To m
            col.Add Item:=wsh.Range("A" & r).Value, Key:=wsh.Range("A" & r).Value
        Next r
    Next wsh
    On Error GoTo 0
    Application.Cursor = xlWait
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each v In col
        ThisWorkbook.Worksheets.Copy
        Set wbk = ActiveWorkbook
        For Each wsh In wbk.Worksheets
            m = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
            For r = m To 4 Step -1
                If wsh.Range("A" & r).Value <> v Then
                    wsh.Range("A" & r).EntireRow.Delete
                End If
            Next r
        Next wsh
        s = ThisWorkbook.Path & "\" & v & ".xlsx"
        wbk.SaveAs Filename:=s, FileFormat:=xlOpenXMLWorkbook
        wbk.Close
    Next v
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Cursor = xlDefault
End Sub

[YasserKhalil]

Wonderful Mr. Hans
I like you code a lot

I just wanted to share the issue and added a line to avoid creating empty worksheets .. I supposed there is a row in one sheet with "DEBIT5" (in just one sheet)
so the code will create worksheets and there will no data in those worksheets

Code: Select all

                Next r
                If wsh.Range("A4").Value = "" Then wsh.Delete
            Next wsh
            
            s = ThisWorkbook.Path & "\" & v & ".xlsx"

[HansV]

Thank you.

[sachin483]

Thanks a lot working fine , but if the criteria in column 'A' is not there in any of the sheets the sheet should get deleted ie criteria is in sheet1 & sheet3 hence sheet2 must be deleted now it is showing blank, can it be done

[YasserKhalil]

Review my post ...

[HansV]

YasserKhalil proposed an addition that should do just that.

[sachin483]

Thanks lot Hans & YasserKhalil it works fine

[YasserKhalil]

You're welcome. All the credits go to Mr. Hans the AWESOME

[HansV]

@Yasser: you deserve credit as well!

[YasserKhalil]

Thank you very much Mr. Hans for your kind words
You have taught me a lot and I am still learning a lot ..

[sachin483]

Hello @Hans & @Yasserkhalil , if i want to freeze top 5 row or 6 rows where i have to modify the macro can you please let me know b,coz in this macro only top 3 rows are freeze , i have tried but not successful

[HansV]

The macro contains the lines

Code: Select all

        For r = 4 To m

and

Code: Select all

            For r = m To 4 Step -1

This makes the macro start at row 4, i.e. the first 3 rows are left alone.
If you want to preserve the first 5 rows, change 4 to 6 in both lines of code.
If you want to preserve the first 6 rows, change 4 to 7 in both lines.

[sachin483]

Thanks a lot and if i want to change the column of selection instead of "A" then where there is "A" i should change the B or C

[HansV]

Yes, that's correct.