Rozumim-li dobre pozadavku, tak zde je trochu ucesana procedura scitajici hodnoty ze sloupcu B7:B1000 (E7:E1000, H7:H1000,...) az 52 krat a ukladajici soucty do bunek dle barvy fontu - cerna do C3 a cervena do C4 (F3:F4, I3:I4,...).

Option Explicit

Sub Scitat()
  Dim Blok As Range, c As Range, Soucet As Range, i As Integer, ofs As Integer
  Set Soucet = Worksheets("list1").Range("c3")
  Set Blok = Worksheets("list1").Range("b7:b1000")
  ofs = 3  ' ofset pro dalsi sloupce
  For i = 0 To 51  ' pocet sloupcu
    Soucet.Offset(0, ofs * i).Value = 0
    Soucet.Offset(1, ofs * i).Value = 0
    For Each c In Blok.Offset(0, ofs * i).Cells
      If IsNumeric(c.Value) Then
        If c.Font.Color = 0 Then Soucet.Offset(0, ofs * i).Value = Soucet.Offset(0, ofs * i).Value + c.Value  ' cerna
        If c.Font.Color = 255 Then Soucet.Offset(1, ofs * i).Value = Soucet.Offset(1, ofs * i).Value + c.Value  ' cervena
      End If
    Next c
  Next i
End Sub

Doplnuji:
Barva je brana pro zakladni barvu fontu, pokud by bylo potreba rozlisovat podle barvy nastavene podminenym formatem, pak je nutno pouzit tytez podminky do procedury a misto c.Font.Color pouzit c.Value=podminka!