jetzt klappt mit deinen und dem MS Beispiel

Option Explicit

Sub InBlöcken()
Const tbStart As String = "A1"
Const intbSpalte As String = "B"

'für die Zeilen in tbStart-Spalte
Dim lngLetzte As Long 'letzte Zeile
Dim x As Long  'Schleife über tbStart-Spalte
Dim lngtbSpalte As Long 'Spaltennummer
Dim rngLetzte As Range  'letzte Zelle der Spalte

'hier wird der Code "Verdoppelt" gebraucht
Dim AbZelle As String
Dim NachSpalte As String

'letzte Zeile in "der" Spalte und dort die letzte Zelle
lngLetzte = Columns(Range(tbStart).Column).Find("*", Range(tbStart), _
  searchOrder:=xlByRows, searchdirection:=xlPrevious).Row
lngtbSpalte = Range(tbStart).Column
Set rngLetzte = Cells(lngLetzte, lngtbSpalte)

'durchlaufe "die" Spalte
For x = 1 To lngLetzte
  'prüfe auf kein Zahlenwert und nicht leer
  'If Not IsNumeric(Cells(x, lngtbSpalte).Value) And _
      Cells(x, lngtbSpalte).Value <> "" Then
  If IsNumeric(Cells(x, lngtbSpalte).Value) And _
      Cells(x, lngtbSpalte).Value <> "" Then
      
    AbZelle = Cells(x, lngtbSpalte).Address 'ab hier
    NachSpalte = intbSpalte 'dorthin schreiben
    BerVerdoppelt AbZelle, NachSpalte, rngLetzte  'Aufrufen und Startwerte übergeben
  End If
Next x

'
End Sub
 
Sub BerVerdoppelt(ByVal Start As String, ByVal inSpalte As String, _
  ByVal rngEnde As Range)
'die Startwerte wurden übergeben
Dim rngStart As Range
Dim rngSpalte As Range
Dim rngIst As Range
Dim lngNext As Long
Dim dblWsF  As Double, dblIst As Double

On Error GoTo errorhandler  'Fehler tritt ein wenn nicht rechenbar

  Set rngStart = Range(Start) 'Beginn
  Set rngSpalte = Range(rngStart.Offset(1, 0), rngEnde) 'Bereich ab Zelle darunter
  lngNext = Columns(inSpalte).Column - rngStart.Column 'im Abstand daneben schreiben
   
  For Each rngIst In rngSpalte  'durchlaufen
  ' so lange summieren, bis die neue Zahl die hinzukommt, das Ergebnis verdoppelt
    dblWsF = WorksheetFunction.sum(Range(rngStart, rngIst))
    dblIst = rngIst.Value + rngIst.Value
    
    If dblIst < dblWsF + 0.001 And dblIst > dblWsF - 0.001 Then
    'If 2 * rngIst.Value = WorksheetFunction.sum(Range(rngStart, rngIst)) Then
          rngIst.Offset(0, lngNext).Value = rngIst.Value  'ausgelesen und in eine Zelle geschrieben werden.
      Set rngStart = rngIst.Offset(1, 0)  'neuer Summenbeginn
    End If
  Next rngIst
   
Exit Sub
errorhandler:
End Sub

Und Tschüüss