Option Explicit
Sub DoTwice()
Const C_REL As String = "=SUM(R[-WERT]C:R[-1]C)"
Dim rngU As Range, rngCol As Range
Dim lngRow As Long, lngHitCol As Long
Dim lngBeg As Long, lngEnd As Long
Dim strAddr As String
Dim flag As Boolean
lngBeg = 1: lngEnd = 1
Set rngU = ActiveSheet.UsedRange
Set rngU = rngU.Offset(1).Resize(rngU.Rows.Count - 1)
Set rngU = Intersect(rngU, Columns("H:BD"))
For Each rngCol In rngU.Columns
lngBeg = 0: lngEnd = 0: strAddr = ""
For lngRow = 1 To rngCol.Cells.Count
lngHitCol = rngCol.Cells(lngRow).DisplayFormat.Interior.ColorIndex
If lngHitCol = 44 Then flag = True
Select Case lngHitCol
Case 36
lngEnd = lngRow
If Not flag Then
rngCol.Cells(lngRow).FormulaR1C1 = Replace(C_REL, "WERT", Format(lngEnd - lngBeg, "#"))
lngBeg = lngEnd + 1
Else
lngBeg = lngBeg + 1
rngCol.Cells(lngRow).FormulaR1C1 = Replace(C_REL, "WERT", Format(lngEnd - lngBeg, "#"))
lngBeg = lngEnd + 1
flag = False
End If
strAddr = strAddr & "+" & rngCol.Cells(lngRow).Address(0, 0)
Case 44
strAddr = Mid(strAddr, 2)
rngCol.Cells(lngRow).Formula = "=" & strAddr
strAddr = ""
End Select
Next lngRow
Next rngCol
End Sub