Sub dsd()
Dim i As Long, col As New Collection, lr As Long
'a = Timer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr
On Error Resume Next
    If Cells(i, 1).Font.ColorIndex <> 1 Then col.Add Cells(i, 1).Font.ColorIndex, CStr(Cells(i, 1).Font.ColorIndex)
Next i
n = 4
For i = 1 To col.Count
    k = 4
    For Z = 1 To lr
        If col(i) = Cells(Z, 1).Font.ColorIndex Then
        Cells(Z, 1).Copy Destination:=Cells(n, k)
            If k + 1 <= 8 Then
                k = k + 1
            Else
                n = n + 1
                k = 4
            End If
        End If
    Next Z
    n = n + 1 + 1
    Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'MsgBox Timer - a
End Sub