größte/kleinste summenreihe

[Marximus]

Hallo liebe Community!

Ich überlege gerade, ob es eine Möglichkeit gibt, sich die größte oder kleinste "Summenreihe" für eine Spalte mit positiven und negativen Zahlen ausgeben zu lassen, also die Summe über eine variable Anzahl an benachbarten Zellen. Dabei möchte ich nicht angeben müssen, wie lang diese Reihe ist. Zum Beispiel bei dieser Reihe:

2
-1
-1
4
5
3
-1
-2
2
-1
-1
-1

Hier wäre die größte Summe benachbarter Zellen 12 (4+5+3) bzw. (2-1-1+4+5+3) und die kleinste -4 (-1-2+2-1-1-1). Ich freue mich über jeden Lösungsansatz!


Liebe Grüße
Max

[BoskoBiati]

Hi,

Ich freue mich über jeden Lösungsansatz!

ich auch. Ich denke, das wird selbst mit VBA nicht ganz leicht. Mal als Idee:

Code:

Sub Summe()
Dim loMax As Long
Dim loMin As Long
Dim loA As Long
Dim loB As Long
Dim loLast As Long
Dim losum As Long
Dim varMax(2) As Variant
Dim varMin(2) As Variant
varMax(0) = 0
varMin(0) = 9999
loLast = Cells(Rows.Count, 1).End(xlUp).Row
For loA = 1 To loLast - 1
    For loB = loA To loLast
        losum = Application.WorksheetFunction.Sum(Range(Cells(loA, 1), Cells(loB, 1)))
        If losum > varMax(0) Then
            varMax(0) = losum
            varMax(1) = loA
            varMax(2) = loB
        End If
        If losum < varMin(0) Then
            varMin(0) = losum
            varMin(1) = loA
            varMin(2) = loB
        End If
    Next
Next
    Range("B1") = "max: " & varMax(0)
    Range("C1") = " ab Zeile " & varMax(1)
    Range("D1") = " bis Zeile " & varMax(2)
    Range("B2") = "min: " & varMin(0)
    Range("C2") = " ab Zeile " & varMin(1)
    Range("D2") = " bis Zeile " & varMin(2)
End Sub

[chris-ka]

Hi,

hier mal auf die schnelle ohne Array

Code:

Sub max_min()
'Daten in Spalte A ab A1 -> Länge egal
Dim i As Integer, mymax As Double, mymin As Double, myvalMax As Double, myvalMin As Double, lastR As Long
lastR = Cells(Rows.Count, 1).End(xlUp).Row
mymax = WorksheetFunction.Min(Range("A1:A" & lastR))
mymin = WorksheetFunction.Max(Range("A1:A" & lastR))
For i = 1 To lastR
    myvalMax = checkMax(Cells(i, 1).Value, i, lastR)
    If myvalMax > mymax Then
        mymax = myvalMax
    End If
     myvalMin = checkmin(Cells(i, 1).Value, i, lastR)
         If myvalMin < mymin Then
        mymin = myvalMin
    End If
Next
MsgBox mymax
MsgBox mymin
End Sub
Function checkMax(lng_Val, myIndex As Integer, lastR As Long) As Double
Dim mysum As Double, dblsum As Double
mysum = lng_Val
dbl_sum = mysum
 For i = myIndex + 1 To lastR
    mysum = mysum + Cells(i, 1).Value
    If mysum > dbl_sum Then
        dbl_sum = mysum
        mysum = dbl_sum
    End If
 Next
  For i = myIndex - 1 To 1 Step -1
    mysum = mysum + Cells(i, 1).Value
    If mysum > dbl_sum Then
        dbl_sum = mysum
        mysum = dbl_sum
    End If
 Next
 checkMax = dbl_sum
End Function
Function checkmin(lng_Val, myIndex As Integer, lastR As Long) As Double
Dim mysum As Double, dblsum As Double
mysum = lng_Val
dbl_sum = mysum
 For i = myIndex + 1 To lastR
    mysum = mysum + Cells(i, 1).Value
    If mysum < dbl_sum Then
        dbl_sum = mysum
        mysum = dbl_sum
    End If
 Next
  For i = myIndex - 1 To 1 Step -1
    mysum = mysum + Cells(i, 1).Value
    If mysum < dbl_sum Then
        dbl_sum = mysum
        mysum = dbl_sum
    End If
 Next
 checkmin = dbl_sum
End Function

sollten mal mehr als 500 Zeilen sein, wäre es über Arrays besser gelöst.

@Edgar

ich auch. Ich denke, das wird selbst mit VBA nicht ganz leicht. Mal als Idee:

Die Idee passt! :), deine Lösung mit Summe ist 100 mal effizienter als alle Zellen abklappern, so wie ich es gemacht habe!

[Marximus]

Wow VBAs, Arrays langsam, langsam :D.

Mal abgesehen, dass ich davon mal so überhaupt keine Ahnung habe und die Lösungen deswegen auch nicht im Ansatz nachvollziehen kann, wo muss ich diesen Paragraphen hinkopieren und wie anpassen, um die Lösung für mein Excelsheet zu übernehmen?

Liebe Grüße
Max