Multiple sheet splitting

**sachin482** · 02-02-2018, 05:45 PM

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
https://www.mrexcel.com/forum/excel-...splitting.html

Code:

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

**DocAElstein** · 02-03-2018, 06:16 PM

Hi sachin482

It would be helpful if you could explain better what your code actually does and how it works.
Possibly you could put some ' Comments in to explain what is going on ion your code

I do not understand fully what it is that you want
Please try to explain better
Better is for example to show us what is you want in another file
It is best to upload another file so that you have a _ Before _ ( already have us given thank you ) and an _ After
_ Before is __ SPLIT1.xlsm
_ After is _ ? ??? _

**sachin482** · 02-03-2018, 07:53 PM

thanks a lot for your help i have attached the out put required and the same has been resolved as per below macro

Code:

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
                If wsh.Range("A4").Value = "" Then wsh.Delete
            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