Copy cell range onto new tabs sorted in groups

[Paul_Hossler]

Re-did the logic to handle Groups not being simple numbers like in first example

Option Explicit


Sub SortIntoGroups()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim r1 As Range
    Dim numGroup As Long, rowIn As Long, rowOut As Long, rowHeader As Long, rowLast As Long
    Dim numInGroup As Long
    Dim collGroups As Collection
    Dim aryGroups() As Variant
    Dim i As Long, j As Long
    Dim vHold As Variant
    
    Worksheets("Main1").Select      '   for testing
    
    'setup and init
    Application.ScreenUpdating = False
    Set collGroups = New Collection
        
    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
    
    'worksheet row numbers
    rowHeader = r1.Rows(1).Row
    rowLast = r1.Cells(2, 2).End(xlDown).Row
    
    
    'load collection to get unique list
    On Error Resume Next
    For rowIn = rowHeader To rowLast
        If UCase(ws1.Cells(rowIn, 8).Value) <> "GROUP" Then
            collGroups.Add ws1.Cells(rowIn, 8).Value, CStr(ws1.Cells(rowIn, 8).Value)
        End If
    Next rowIn
    On Error GoTo 0
    
    'make array
    ReDim aryGroups(1 To collGroups.Count)
    For numGroup = LBound(aryGroups) To UBound(aryGroups)
        aryGroups(numGroup) = collGroups.Item(numGroup)
    Next numGroup
    
    
    'sort array
    For i = LBound(aryGroups) To UBound(aryGroups) - 1
        For j = i + 1 To UBound(aryGroups)
            If aryGroups(j) < aryGroups(i) Then
                vHold = aryGroups(i)
                aryGroups(i) = aryGroups(j)
                aryGroups(j) = vHold
            End If
        Next j
    Next i
    
    rowOut = 1
    For numGroup = LBound(aryGroups) To UBound(aryGroups)
        
        numInGroup = 1
        
        'add GROUP x
        ws2.Cells(rowOut, 2).Value = "GROUP " & aryGroups(numGroup)
        rowOut = rowOut + 1
        
        'add header for each group
        ws1.Rows(rowHeader).Copy ws2.Cells(rowOut, 1)
        rowOut = rowOut + 1
        
        
        'loop all input rows numGroup times pulling each group individually
        For rowIn = rowHeader + 1 To rowLast
            If ws1.Cells(rowIn, 8).Value = aryGroups(numGroup) Then
                ws1.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