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