AW: Fehler(Summe) bei Code durch KI
03.09.2024 12:35:35
peter
Hallo
Sub FarbeabwechseldeMitSumme_T5()
Dim rng As Range
Dim cell As Range
Dim lastRow As Long
Dim currentValue As String
Dim colorIndex As Long
Dim count As Long
Dim sum As Double
Dim lastCell As Range
' Dynamische letzte Zeile ermitteln
lastRow = Cells(Rows.count, "I").End(xlUp).Row
Set rng = Range("I3:I" & lastRow)
' Initialisiere den Farbindex und Zähler
colorIndex = 6 ' Gelb
' Suche den ersten Wert in Spalte I und initialisiere CurrentValue
For Each cell In rng
If cell.Value > "" Then
currentValue = cell.Value
Exit For
End If
Next
count = 1
sum = 0
' Schleife durch jede Zelle im Bereich
For Each cell In rng
' Überprüfen, ob die Zelle nicht leer ist
If cell.Value > "" Then
' Wenn der Wert der Zelle sich vom aktuellen Wert unterscheidet, Farbe wechseln
If cell.Value > currentValue Then
' In der letzten Zelle vor dem Farbwechsel die Summe in Spalte F eintragen
If count > 0 Then
lastCell.Offset(0, -3).Value = sum ' Summe in Spalte F eintragen
Rows(lastCell.Row + 1).Insert Shift:=xlDown ' Leere Zeile einfügen
End If
' Farbe wechseln
If colorIndex = 6 Then
colorIndex = 8 ' Blau
Else
colorIndex = 6 ' Gelb
End If
' Zähler und Summe zurücksetzen
currentValue = cell.Value
count = 1
sum = 0
Set lastCell = cell
Else
' Zähler und Summe erhöhen
count = count + 1
sum = sum + Cells(cell.Row, "E").Value ' Annahme: Werte stehen in Spalte E
Set lastCell = cell
End If
' Zelle färben
cell.Interior.colorIndex = colorIndex
End If
Next cell
' Letzte Gruppe verarbeiten
If count > 0 Then
lastCell.Offset(0, -3).Value = sum ' Summe in Spalte F eintragen
Rows(lastCell.Row + 1).Insert Shift:=xlDown ' Leere Zeile einfügen
End If
End Sub
Peter