Multiple sheet splitting

[sachin482]

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-questions/1041465-multiple-sheet-splitting.html




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]

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]

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



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

[DocAElstein]

Hi
Thanks for sharing your solution
:)

Edit: please do not forget to add links to ALL cross postings
http://www.eileenslounge.com/viewtopic.php?f=30&t=29037
;)