Maybe like this ?
Sub Test()
  Dim coll As New Collection, arr(), c As Long, i As Long, j As Long, strKey As String
  With Sheets("Sheet1")
    i = Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, .Cells(.Rows.Count, "F").End(xlUp).Row)
    arr = .Range("A3:J" & i).Value
  End With
  For j = 1 To UBound(arr, 2) Step 5
      For i = 1 To UBound(arr, 1)
          If Len(arr(i, j)) Then
             On Error Resume Next
                coll.Add key:=arr(i, j), Item:=New Collection
             On Error GoTo 0
             coll(arr(i, j)).Add Empty
          End If
      Next i
  Next j
  For j = 1 To UBound(arr, 2) Step 5
      For i = 1 To UBound(arr, 1)
          If Len(arr(i, j)) Then
             With coll(arr(i, j))
               If .Count = 2 Then
                  c = c + 1
                  arr(i, j + 4) = Val("1." & Format$(c, "00000"))
                  .Add arr(i, j + 4)
               ElseIf .Count = 3 Then
                  arr(i, j + 4) = .Item(.Count)
               End If
             End With
          End If
      Next i
  Next j
  With Sheets("Output")
    .Cells.Clear
    Sheets("Sheet1").Rows(2).Copy .Rows(2)
    With .Range("A3").Resize(UBound(arr, 1), UBound(arr, 2))
      .Value = arr
      .Columns("A:E").Sort key1:=.Columns("E"), order1:=xlAscending, key2:=.Columns("A"), order2:=xlAscending, header:=xlNo
      .Columns("F:J").Sort key1:=.Columns("J"), order1:=xlAscending, key2:=.Columns("F"), order2:=xlAscending, header:=xlNo
      Intersect(.Areas(1), .Columns("E").SpecialCells(xlCellTypeConstants).EntireRow).Interior.Color = 16777164
      .Columns("E").Clear
      .Columns("J").Clear
    End With
  End With
End Sub