Summe über ActiveCell

Sub Insert_Sum() Dim k As Long, i As Long k = 1 For i = 1 To Range("A65536").End(xlUp).Row + 1 Cells.Find(what:="Summe", LookAt:=xlPart).Activate Zelle = ActiveCell.Offset(0, 5).Select Zelle = Application.WorksheetFunction.Sum(Range(Cells(k, 0), Cells(i - 1, 0))) ActiveCell.Font.Bold = True k = i + 1 'Set Zelle = Cells.FindNext(After:=ActiveCell) Next i End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub xx() Dim I&, Summen As Double Summen = 0 For I = 1 To Range("A65536").End(xlUp).Row + 1 If LCase(Cells(I, 1)) <> "summe" Then Summen = Summen + Cells(I, 6) Else Cells(I, 6) = Summen Summen = 0 End If Next End Sub

Sub Insert_Sum() Dim rngToSearchIn As Range Dim rngCell As Range Set rngToSearchIn = Range("a1:a" & Range("A65536").End(xlUp).Row) For Each rngCell In rngToSearchIn.Cells If (rngCell.Value = "Summe" And rngCell.Row > 1) Then rngCell.Offset(0, 5).FormulaR1C1 = "=SUM(R[-" & (rngCell.Row - 1) & "]C:R[-1]C)" rngCell.Font.Bold = True End If Next rngCell End Sub

Sub Insert_Sum() Dim rngToSearchIn As Range Dim rngCell As Range Set rngToSearchIn = Range("a1:a" & Range("A65536").End(xlUp).Row) For Each rngCell In rngToSearchIn.Cells If (rngCell.Value = Cells.Find(what:="Summe", LookAt:=xlPart) And rngCell.Row > 1) Then rngCell.Offset(0, 5).FormulaR1C1 = "=SUM(R[-" & (rngCell.Row - 1) & "]C:R[-1]C)" rngCell.Font.Bold = True End If Next rngCell End Sub

Hallo Stefan,
ich habe es mir ueberlegt, und festgestellt, dass ich Deine Aufgabe moeglicher Weisse nicht richtig verstanden habe :-). Schau Dir den ergebnis selbs mal an. Hier die alte Version:


Sub Insert_Sum_1()
Dim rngToSearchIn As Range
Dim rngCell As Range
Set rngToSearchIn = Range("a1:a" & Range("A65536").End(xlUp).Row)
For Each rngCell In rngToSearchIn.Cells
If (VBA.InStr(1, UCase(rngCell.Value), "SUMM") > 0 And rngCell.Row > 1) Then
rngCell.Offset(0, 5).FormulaR1C1 = "=SUM(R[-" & (rngCell.Row - 1) & "]C:R[-1]C)"
rngCell.Font.Bold = True
End If
Next rngCell
End Sub

Und hier die neue Version:


Sub Insert_Sum_2()
Dim rngToSearchIn As Range
Dim rngCell As Range
Dim lngRowWithPreviousSumm As Long
Set rngToSearchIn = Range("a1:a" & Range("A65536").End(xlUp).Row)
For Each rngCell In rngToSearchIn.Cells
If (VBA.InStr(1, UCase(rngCell.Value), "SUMM") > 0) Then
If (rngCell.Row > (lngRowWithPreviousSumm + 1)) Then
rngCell.Offset(0, 5).FormulaR1C1 = "=SUM(R[-" & (rngCell.Row - lngRowWithPreviousSumm - 1) & "]C:R[-1]C)"
End If
lngRowWithPreviousSumm = rngCell.Row
rngCell.Font.Bold = True
End If
Next rngCell
End Sub

Die neue Version ist erweitert und macht eigentlich das selbe, was auch das Code vom Fritz macht :-), nur dass es die Formel direct in die Zellen shcreibt => so kann man die Formeln auch kontrolieren. Gruss Dan.

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread