Copy cell range onto new tabs sorted in groups

[Paul_Hossler]

Look at this and see if it suits

"Main1" is input to make "Main1-Sorted" as output in the attachment

There are some assumptions made as to the input data structure -- these can be generalized if necessary

Option Explicit


Sub SortIntoGroups()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim r1 As Range
    Dim numGroups As Long, numGroup As Long, rowIn As Long, rowOut As Long, rowHeader As Long, rowLast As Long
    Dim numInGroup As Long
    
    'setup and init
    Application.ScreenUpdating = False
    
        
'    Worksheets("Main1").Select      '   for testing
    
    
    Set ws1 = ActiveSheet
    
    'delete output sheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(ws1.Name & "-Sorted").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    'create output sheet after input with -Sorted suffix
    Worksheets.Add(, ws1).Name = ws1.Name & "-Sorted"
    Set ws2 = Worksheets(ws1.Name & "-Sorted")
    
    'set source data
    If Len(ws1.Cells(1, 1).Value) = 0 Then
        Set r1 = ws1.Cells(1, 1).End(xlDown).CurrentRegion
    Else
        Set r1 = ws1.Cells(1, 1).CurrentRegion
    End If
    
    rowHeader = r1.Rows(1).Row
    rowLast = r1.Cells(2, 2).End(xlDown).Row
    
    numGroups = Application.WorksheetFunction.Max(r1.Columns(8))
    rowOut = 1
    For numGroup = 1 To numGroups
        
        numInGroup = 1
        
        'add GROUP x
        ws2.Cells(rowOut, 2).Value = "GROUP " & numGroup
        rowOut = rowOut + 1
        
        'add header for each group
        r1.Rows(1).Copy ws2.Cells(rowOut, 1)
        rowOut = rowOut + 1
        
        
        'loop all input rows numGroup times pulling each group individually
        For rowIn = rowHeader To rowLast
            If r1.Cells(rowIn, 8).Value = numGroup Then
                r1.Rows(rowIn).Copy ws2.Cells(rowOut, 1)
                ws2.Cells(rowOut, 1).Value = numInGroup
                numInGroup = numInGroup + 1
                rowOut = rowOut + 1
            End If
        
        Next rowIn
    
        'insert blank line
        rowOut = rowOut + 1
    Next numGroup
    'cleanup
    Application.ScreenUpdating = True
End Sub