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

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!

Loop through sheets, copy headers 1st, use advanced filter to grab data, and copy your sum last — urdearboy
@urdearboy: as the question is probably on-topic, you could make an answer out of your comment... — Our Man in Bananas
Are your sums just a standard sum from 5th Row down to bottom row? — urdearboy

Art Art · Accepted Answer · 2018-07-27T19:08:48

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

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

1 Answers