Sub SortByColor()
    Dim rCell As Range, rRow As Range, i As Long, LastRow As Long, NextRow As Long
    Application.ScreenUpdating = False
    Sheets(2).Cells.Clear
    For Each rRow In Sheets(1).Range("A5").CurrentRegion.Rows
        For Each rCell In rRow.Cells
            If rCell.Font.Color = vbRed Then
                i = i + 1
            End If
        Next rCell
        Select Case i
            Case 6
                LastRow = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1
                rRow.Copy Sheets(2).Cells(LastRow, 1)
            Case 5
                LastRow = Sheets(2).Cells(Rows.Count, 7).End(xlUp).Row + 1
                rRow.Copy Sheets(2).Cells(LastRow, 7)
            Case 4
                LastRow = Sheets(2).Cells(Rows.Count, 13).End(xlUp).Row + 1
                rRow.Copy Sheets(2).Cells(LastRow, 13)
            Case 3
                LastRow = Sheets(2).Cells(Rows.Count, 19).End(xlUp).Row + 1
                rRow.Copy Sheets(2).Cells(LastRow, 19)
            Case 2
                LastRow = Sheets(2).Cells(Rows.Count, 25).End(xlUp).Row + 1
                rRow.Copy Sheets(2).Cells(LastRow, 25)
            Case 1
                LastRow = Sheets(2).Cells(Rows.Count, 31).End(xlUp).Row + 1
                rRow.Copy Sheets(2).Cells(LastRow, 31)
        End Select
        i = 0
    Next rRow
    
    For i = 7 To 31 Step 6
        LastRow = Sheets(2).Cells(Rows.Count, i).End(xlUp).Row
        If LastRow > 1 Then
            NextRow = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1
            Sheets(2).Range(Sheets(2).Cells(2, i), Sheets(2).Cells(LastRow, i + 5)).Cut Sheets(2).Cells(NextRow, 1)
        End If
    Next i
    Sheets(2).Activate
End Sub

Sub AllRedFirst()
  Dim rg As Range, rw As Range, c&, n&
  [g:g].ClearContents
  Set rg = Range(Cells(Rows.Count, 1).End(xlUp), Cells(Rows.Count, 6).End(xlUp).End(xlUp))
  Application.ScreenUpdating = False
  For Each rw In rg.Rows
    For c = 1 To 6
      If rw.Cells(c).Font.Color <> 255 Then Exit For
    Next
    If c = 7 Then n = n + 1: Cells(rw.Row, 7) = n
  Next
  Application.ScreenUpdating = True
  With Worksheets(2)
    .Cells.ClearContents
    rg.Resize(rg.Rows.Count, rg.Columns.Count + 1).Copy .Cells(1)
    [g:g].ClearContents
    SortRangeBy .[a1].Resize(rg.Rows.Count, 7), Array(7), 0
    .[g:g].ClearContents
    .Activate
  End With
End Sub


Sub SortRangeBy(rg As Range, c, Optional Hd& = 1)
  Dim i&
  With rg.Parent.Sort
    .SortFields.Clear
    For i = LBound(c) To UBound(c)
      .SortFields.Add Key:=rg.Cells(1).Offset(Hd, Abs(c(i)) - 1).Resize( _
      rg.Rows.Count - Hd, 1), SortOn:=xlSortOnValues, Order:=IIf(c(i) > 0, _
      1, 2), DataOption:=xlSortNormal
    Next
    .SetRange rg: .Header = Hd: .MatchCase = False
    .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
  End With
End Sub