OK - mal nach "deinen" Angaben gestrickt in etwa so
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
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
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
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
|