Summe dynamisch mit Makro

Hallo Excel-Forum, ich habe eine Liste, die monatlich in der Länge variiert. Mit nachfolgendem Makro füge ich jeweils 2 Zeilen ein, wenn die Kennung in Spalte "A" wechselt. Dann sollte pro Kennung eine Summe in Spalte "B" gebildet werden. Das Problem ist, dass die Länge der Kennung monatlich variiert.
Wie kann ich mittels Makro jeweils die Summe über die unterschiedlichen Kennungen bilden. Hatte an Variablen für Anfang und Ende der Kennung gedacht und dann diese in die Summe einzubauen. Da kennt ihr Spezialisten aber bestimmt einen eleganteren / einfacheren Weg.
Wäre dankbar, wenn mich dabei jemand unterstützen könnte.
Danke schon mal.
Peter

Sub test()
Dim lngRow As Long, i As Long
lngRow = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For i = lngRow To 3 Step -1
If Cells(i - 1, 1)  Cells(i, 1) Then
Rows(i).EntireRow.Insert Shift:=xlDown
Rows(i).EntireRow.Insert Shift:=xlDown
Rows(i).Select
Selection.RowHeight = 12
End If
Next i
Application.ScreenUpdating = True
End Sub

https://www.herber.de/bbs/user/135428.xlsx

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub SummeEinfuegen() Dim lngRow As Long, i As Long Dim lngStart As Long lngRow = Cells(Rows.Count, "A").End(xlUp).Row lngStart = Application.CountIf(Columns(1), Cells(lngRow, 1)) Cells(lngRow + 1, 2) = Application.Sum(Range(Cells(lngRow - lngStart + 1, 1), _ Cells(lngRow, 2))) For i = lngRow - lngStart + 1 To 4 Step -1 lngStart = Application.CountIf(Columns(1), Cells(i - 1, 1)) Rows(i & ":" & i + 1).Insert shift:=xlDown Cells(i, 2) = Application.Sum(Range(Cells(i - lngStart, 1), Cells(i - 1, 2))) i = i - lngStart + 1 Next i End Sub

Sub test() Dim z As Long Dim Zelle As Range '--- Leerzeilen einf?gen For z = Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1 If Cells(z, 1) Cells(z - 1, 1) Then Rows(z).Resize(2).Insert Next '--- Summen einf?gen For Each Zelle In Columns(2).SpecialCells(xlCellTypeConstants, 1).Areas With Zelle(1).Offset(Zelle.Rows.Count) .Formula = "=Sum(" & Zelle.Address(0, 0) & ")" .Font.Bold = True end with Next End Sub

Sub Einfuegen() Dim lngRow As Long, i As Long Dim lngStart As Long lngRow = Cells(Rows.Count, "A").End(xlUp).Row lngStart = Application.CountIf(Columns(1), Cells(lngRow, 1)) Application.ScreenUpdating = False Cells(lngRow + 1, 2) = Application.Sum(Range(Cells(lngRow - lngStart + 1, 1), _ Cells(lngRow, 2))) For i = lngRow - lngStart + 1 To 3 Step -1 lngStart = Application.CountIf(Columns(1), Cells(i - 1, 1)) Rows(i & ":" & i + 1).Insert shift:=xlDown Cells(i, 2) = Application.Sum(Range(Cells(i - lngStart, 1), Cells(i - 1, 2))) i = i - lngStart + 1 If Cells(i - 2, 1) = "Kennung" Then Exit For Next i Application.ScreenUpdating = True End Sub

Sub test() Dim z As Long Dim Zelle As Range '--- Leerzeilen einf?gen For z = Cells(Rows.Count, 1).End(xlUp).Row To 5 Step -1 If Cells(z, 1) Cells(z - 1, 1) Then Rows(z).Resize(3).Insert Next '--- Summen einfuegen For Each Zelle In Columns(2).SpecialCells(xlCellTypeConstants, 1).Areas With Zelle(1).Offset(Zelle.Rows.Count) .Formula = "=Sum(" & Zelle.Address(0, 0) & ")" .Font.Bold = True End With Next For Each Zelle In Columns(3).SpecialCells(xlCellTypeConstants, 1).Areas With Zelle(1).Offset(Zelle.Rows.Count) .Formula = "=Sum(" & Zelle.Address(0, 0) & ")" .Font.Bold = True End With Next End Sub

Sub test() Dim z As Long Dim Zelle As Range Dim adr As String '--- Leerzeilen einf?gen For z = Cells(Rows.Count, 1).End(xlUp).Row To 5 Step -1 If Cells(z, 1) Cells(z - 1, 1) Then Rows(z).Resize(3).Insert Next '--- Summen einfuegen For Each Zelle In Columns(1).SpecialCells(xlCellTypeConstants).Areas adr = Zelle.Address(0, 0) With Zelle(1).Offset(Zelle.Rows.Count).Resize(, ActiveSheet.Cells.SpecialCells( _ xlCellTypeLastCell).Column) .Formula = "=IF(Count(" & adr & "),Sum(" & adr & "),"""")" .Cells.SpecialCells(xlFormulas, 2).ClearContents .Font.Bold = True End With Next End Sub

Sub Einfuegen() Dim lngRow As Long, i As Long Dim lngStart As Long lngRow = Cells(Rows.Count, "A").End(xlUp).Row lngStart = Application.CountIf(Columns(1), Cells(lngRow, 1)) Application.ScreenUpdating = False Union(Range(Cells(lngRow + 1, 2), Cells(lngRow + 1, 4)), Cells(lngRow + 1, 6)).Formula = _ "=SUM(" & Range(Cells(lngRow - lngStart + 1, 2), _ Cells(lngRow, 2)).Address(0, 0) & ")" For i = lngRow - lngStart + 1 To 3 Step -1 lngStart = Application.CountIf(Columns(1), Cells(i - 1, 1)) Rows(i & ":" & i + 1).Insert shift:=xlDown Union(Range(Cells(i, 2), Cells(i, 4)), Cells(i, 6)).Formula = _ "=SUM(" & Range(Cells(i - lngStart, 2), Cells(i - 1, 2)).Address(0, 0) & ")" i = i - lngStart + 1 If Cells(i - 2, 1) = "Kennung" Then Exit For Next i Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread