Перебор ячеек с удалениями: требуется code review

Dim lARow As Long
Dim lBRow As Long
Dim cCell As Range
 
lARow = 1: lBRow = 1
 
[A:A].Insert xlShiftToRight 'отодвигаем первый столбец вправо: нам понадобятся 2 временных пустых столбца
[A:A].Insert xlShiftToRight
 
'теперь наш текст в столбце С
For Each cCell In [C:C].SpecialCells(xlCellTypeConstants) 'проходим все не пустые ячейки
    If cCell.Characters.Font.Color = 0 Then 'проверяем, черный ли цвет у текста в ячейке
        cCell.Cut ActiveSheet.Cells(lBRow, 2) 'в столбец B переносим черные
        lBRow = lBRow + 1
    Else 'в случае False и Null
        cCell.Cut ActiveSheet.Cells(lARow, 1) 'в столбец A переносим цветные
        lARow = lARow + 1
    End If
Next cCell
 
If lBRow > 1 Then 'если черные вообще были
    Range([B1], [B1].End(xlDown)).Cut ActiveSheet.Cells(lARow, 1) 'добавляем черные столбцы в конец цветных
End If
 
[C:C].Delete: [B:B].Delete 'удаляем ненужные столбцы B и C

Set rSelection = Selection
i = 1
i_max = rSelection.Count
Do
   Set cCell = rSelection(i)
   If cCell.Characters.Font.Color = 0 Then
      i = i + 1
   Else
      cCell.Cut 'вырезаем
      [A1].Insert xlShiftDown 'вставляем в начало
      i_max = i_max - 1
   End If
Loop

Sub sulfur()
  Dim r As Range, c As Range, a(), b()
  Set r = Range([a1], Cells(Rows.Count, 1).End(xlUp))
  a = r.value
  ReDim b(1 To UBound(a), 1 To 1)
  For Each c In r.SpecialCells(xlCellTypeConstants)
'    b(c.Row, 1) = c.Font.ColorIndex
    If c.Font.ColorIndex = 1 Then b(c.Row, 1) = 2 Else b(c.Row, 1) = 1
  Next
  r.Offset(0, 1).value = b
  r.Resize(, 2).Sort Key1:=[b1], Order1:=xlAscending, Header:=xlGuess
  r.Offset(0, 1).Clear
End Sub

Sub sulfur()
  Dim r As Range, c As Range, b()
  Set r = Range([a1], Cells(Rows.Count, 1).End(xlUp))
  ReDim b(1 To r.Rows.Count, 1 To 1)
  For Each c In r.SpecialCells(xlCellTypeConstants)
    If c.Font.ColorIndex = 1 Then b(c.Row, 1) = 2 Else b(c.Row, 1) = 1
  Next
  r.Offset(0, 1).value = b
  r.Resize(, 2).Sort Key1:=[b1], Order1:=xlAscending, Header:=xlGuess
  r.Offset(0, 1).Clear
End Sub

Sub sulfur()
  Dim r As Range, c As Range
  Set r = Range([a1], Cells(Rows.Count, 1).End(xlUp))
  For Each c In r.SpecialCells(xlCellTypeConstants)
    If c.Font.ColorIndex = 1 Then c.Offset(0,1) = 2 Else c.Offset(0,1) = 1
  Next
  r.Resize(, 2).Sort Key1:=[b1], Order1:=xlAscending, Header:=xlGuess
  r.Offset(0, 1).Clear
End Sub