Copy all rows with unique values to new worksheets including header's rows - excel

Question

I'm trying to fix the code to copy all rows based on unique values in a column to new worksheets
1. The table has a header in the range A1:CM4 that also includes a small picture
2. The last row contains a SUM formulas for each column C:CM
Trying to get:
1. Create new worksheets for each unique values in a column A (copy all appropriate rows, some cells are empty) including the header (A1:CM4) with the picture
3. Name new worksheets based on unique values (can be long names with spaces and commas: "aaaaa and bbbb, cccc")
4. The last row should contain SUM formulas and formatting for each column C:CM
I have a code that does part of the job (creates new sheets with unique values), but still struggling to fix next issues:
1. Doesn't copy all header (now copies only 1st row out of 4)
2. Doesn't keep/copy the last row with SUM formulas
3. Doesn't name a worksheet if the unique value is like: "aaaaa and bbbb, cccc" (less important)
Sub unique_data()
Dim RCount As Long
Dim Sht As Worksheet
Dim NSht As Worksheet
Dim I As Long
Dim TRrow As Integer
Dim Col As New Collection
Dim Title As String
Dim SUpdate As Boolean
Set Sht = ActiveSheet
On Error Resume Next
RCount = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row - 1
Title = "A1"
TRrow = Sht.Range(Title).Cells(1).Row
For I = 5 To RCount
Call Col.Add(Sht.Cells(I, 1).Text, Sht.Cells(I, 1).Text)
Next
SUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To Col.Count
Call Sht.Range(Title).AutoFilter(1, CStr(Col.Item(I)))
Set NSht = Nothing
Set NSht = Worksheets(CStr(Col.Item(I)))
If NSht Is Nothing Then
Set NSht = Worksheets.Add(, Sheets(Sheets.Count))
NSht.Name = CStr(Col.Item(I))
Else
NSht.Move , Sheets(Sheets.Count)
End If
Sht.Range("A" & TRrow & ":A" & RCount).EntireRow.Copy NSht.Range("A1")
NSht.Columns.AutoFit
Next
Sht.AutoFilterMode = False
Sht.Activate
Application.ScreenUpdating = SUpdate
MsgBox "All done!", vbExclamation
End Sub
Would be very grateful for any help!

Answer 1

I managed to fix my code and get the correct results (still have some issues with naming spreadsheets as some names are rather long and excel does not take them to name the tabs), but anyways here is what the code is doing:
1. Creates new spreadsheets and copies appropriate rows based on unique values in a certain range (A5:..) of the main sheet
2. Renames new spreadsheets based on unique values
3. Copies all header's rows (4) to new spreadsheets
4. Copies the last row with SUM formulas and adjust the sum range for each spreadsheets based on the number of returned records
5. Formats new spreadsheets
I hope someone can use this code to solve similar puzzles or maybe make it more efficient.
Sub unique_data()
Dim RCount As Long
Dim Sht As Worksheet
Dim NSht As Worksheet
Dim I As Long
Dim Col As New Collection
Dim SUpdate As Boolean
Dim Lrow As Long
Dim NShtLR As Long
Set Sht = ActiveSheet
On Error Resume Next
RCount = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row - 1
Lrow = Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row
For I = 5 To RCount
Call Col.Add(Sht.Cells(I, 1).Text, Sht.Cells(I, 1).Text)
Next
SUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To Col.Count
Call Sht.Range("A5").AutoFilter(1, CStr(Col.Item(I)))
Set NSht = Nothing
Set NSht = Worksheets(CStr(Col.Item(I)))
If NSht Is Nothing Then
Set NSht = Worksheets.Add(, Sheets(Sheets.Count))
NSht.Name = CStr(Col.Item(I))
Else
NSht.Move , Sheets(Sheets.Count)
End If
Sht.Range("A5:A" & RCount).EntireRow.Copy NSht.Range("A5")
Next
Sheets.FillAcrossSheets Sht.Range("1:4")
For Each NSht In Worksheets
If Not NSht.Name = "MainReport" Then
NSht.Select
NShtLR = NSht.Cells(Sht.Rows.Count, 1).End(xlUp).Row + 1
Sht.Range("A" & Lrow).EntireRow.Copy NSht.Range("A" & NShtLR)
NSht.Range("C" & NShtLR).Formula = "=SUM(C5:C" & NShtLR - 1 & ")"
Range("C" & NShtLR).Copy Range("C" & NShtLR & ":CM" & NShtLR)
Rows("4:4").RowHeight = 230
Columns("A:A").ColumnWidth = 28
Columns("B:B").ColumnWidth = 29
Columns("C:C").ColumnWidth = 3
Columns("D:CB").ColumnWidth = 3.5
Columns("CC:CM").ColumnWidth = 4
NSht.Shapes.Range(Array("Picture 1")).Select
Selection.ShapeRange.IncrementLeft -3.6
Selection.ShapeRange.IncrementTop 47.4
Rows.EntireRow.Hidden = False
ActiveWindow.Zoom = 70
End If
Next
Sht.AutoFilterMode = False
Sht.Activate
Application.ScreenUpdating = SUpdate
MsgBox "All done!", vbExclamation
End Sub