Formeln bzw. Lösung optimierbar?

Hallo,
wir haben für ein kleines Projekt grundsätzlich bereits eine Lösung. Allerdings steigt aufgrund des Gesamtumfangs mittlerweile der Ressourcenbedarf der EXCEL-Datei stark an. Wir vermuten, dass einige unserer Formeln verbessert bzw. vereinfacht werden könnten. Ggfls. könnte auch VBA helfen das können wir aber abschließend nicht beurteilen.
Für die Erklärung der Problemstellung haben wir eine Musterdatei erstellt (die Originaldatei ist in den genannten Bereichen natürlich wesentlich umfangreicher):
1. Tabelle Grunddaten: Bereich C2 bis L200 mit positiven oder negativen Zahlen; Überschriften: C1 bis L1; die Grunddaten werden von Zeit zu Zeit immer wieder aktualisiert mit neuen Zahlen; die Zahlen können immer positiv oder negativ sein
2. Tabelle Summieren: hier werden pro Spalte (= Spalten C bis L, sind identisch mit Spalten Grunddaten) immer die Zellinhalte von vier Zeilen summiert; also Summe(C2:C5); Summe(C3:C6) usw.; die Summenergebnisse sind ebenfalls wiederum sowohl positiv als auch negativ
3. Tabelle ermitteln:
a) hier wird ermittelt welche Summenergebnisse (aus den Spalten der Tabelle Summieren) wie oft pro Spalte vorkommen
b) nun ist das Ziel, jeweils diejenige Zahl (=Summenergebnis) innerhalb einer Spalte zu finden, die eine bestimmte Grenze dadurch überschreitet, dass durch das zählen von größeren Zahlen (bei positiven Zahlen) oder kleineren Zahlen (bei negativen Zahlen diese Grenze erreicht wird.
Beispiel gem. Musterdatei: in der Tabelle Summieren, Spalte C ist der größte Wert 69; dieser kommt 3x vor; dann gibt es noch die 67, 63, 60, 58 je einmal und die 56 3x (=insg 10x vorkommend); da die Grenze 12 (Tabelle ermitteln, Zelle U3) ist, wird die Zahl aus der Spalte C die durch weiteres Zählen in der Spalte C (Tabelle Summieren bzw. Tabelle ermitteln) gesucht, die die 12 erreicht: das ist im Beispiel die 54!!
Auf dem gleichen Wege passiert dies auch bei den negativen Zahlen, wobei bei der kleinsten Zahl das zählen begonnen wird; Grenze = 25 (Zelle U2), gesuchte Zahl ist -43.
Wir kommen zu den Ergebnissen derzeit dadurch, dass wir eine Hilfsrechnung pro Spalte in den Spalten AG bis AP erstellt haben (dort wird quasi hochgezählt). Eventuell kann ja diese Hilfsrechnung entfallen oder es gibt bessere Formeln in den Spalten V bis AE.
In den Bereichen V bis AE und AG bis AP benötigen wir derzeit auch zwei unterschiedliche Formeln, je nachdem ob die gesuchte Zahl positiv oder negativ ist.
Also insgesamt kommen wir zu der von uns gewollten Lösung aber evtl. kann man da Teilbereiche optimieren und wir können den Ressourcenbedarf (ggfls. deutlich) reduzieren.
https://www.herber.de/bbs/user/109090.xlsx
Besten Dank wenn sich jemand die Mühe macht zu dem umfangreichen Inhalt und vielleicht auch einen Verbesserungsvorschlag hat!
mfg

Hallo Bastian,
beim Versuch die Erweiterung von heute einzubauen sind wir doch gescheitert:
1. Zunächst haben wir die Muster von 1 - 10 auf 1 - 251 erweitert, kein Problem:
2. Ein weiteres Tabellenblatt "Summieren" mit "Summieren2" beinhaltet eine geänderte Formel; es werden nur 3 statt 4 Zeilen aufsummiert = kein Problem!!
3. In diesem Tabellenblatt muss jetzt Maxist und Minist "neu berechnet werden" - das klappt nicht.
4. Ein weiteres Tabellenblatt mit "ermitteln2" wird jetzt aus den Daten von "Summieren2" bedient, aber da gibt es dann eine Fehlermeldung.
Ich habe die Datei von heute morgen um die beiden genannten Tabellenblätter erweitert sowie den Code für den "zweiten Durchlauf" erweitert. Die Änderungen bzw. die Fehlermeldung wurden kommentiert im Code. Siehe insbesondere nach dem Hinweis neuer Durchlauf mit neuen Tabellen "2"
Leider kann ich die Datei nicht hochladen, da größer 300 KB, deswegen hier der "neue Code":

Sub Create()
Dim WSarr()
Dim xx As Long, R1 As Long, C As Long, First As Long, Last As Long, counter As Long
With ThisWorkbook
With .Sheets("Grunddaten").Range("C1").CurrentRegion
WSarr = .Resize(.Rows.Count + 2).Value
End With
With .Sheets("Summieren")
For Rl = LBound(WSarr, 1) + 1 To UBound(WSarr, 1) - 3
For C = LBound(WSarr, 2) To UBound(WSarr, 2)
WSarr(Rl, C) = WSarr(Rl, C) + WSarr(Rl + 1, C) + WSarr(Rl + 2, C) + WSarr(Rl + 3, C)
If Maxist  WSarr(Rl, C) Then Minist = WSarr(Rl, C)
Next
Next
.Columns("C:IS").Clear
.Range("C1").Resize(UBound(WSarr, 1), UBound(WSarr, 2)) = WSarr
.Range("IV2") = Maxist
.Range("IV3") = Minist
.Columns.AutoFit
End With
With .Sheets("ermitteln")
First = Maxist
Last = Minist
ReDim WsArrER(First + Abs(Last) + 1, 251)  ' 10 bisher
For i = First To Last Step -1
For C = LBound(WSarr, 2) To UBound(WSarr, 2)
counter = 0
For Rl = LBound(WSarr, 1) + 1 To UBound(WSarr, 1) - 2
If WSarr(Rl, C) = i Then
counter = counter + 1
End If
Next
WsArrER(xx, UBound(WsArrER, 2)) = WsArrER(xx, UBound(WsArrER, 2)) + counter
WsArrER(xx, C - 1) = counter
Next
xx = xx + 1
Next
' .UsedRange.Offset(0, 1).Clear
.Range("C4").Resize(UBound(WsArrER, 1), UBound(WsArrER, 2) + 1) = WsArrER
ReDim Preserve WsArrER(UBound(WsArrER, 1), UBound(WsArrER, 2) - 1)
For C = LBound(WsArrER, 2) To UBound(WsArrER, 2)
counter = 0
For xx = LBound(WsArrER, 1) To First - 1
counter = counter + WsArrER(xx, C)
WsArrER(xx, C) = counter
Next
Next
For C = LBound(WsArrER, 2) To UBound(WsArrER, 2)
counter = 0
For xx = UBound(WsArrER, 1) To First + 1 Step -1
counter = counter + WsArrER(xx, C)
WsArrER(xx, C) = counter
Next
Next
For C = LBound(WsArrER, 2) To UBound(WsArrER, 2)
WsArrER(First, C) = ""
Next
.Range("IZ2") = Maxist
.Range("IZ3") = Minist
.Range("SU4").Resize(UBound(WsArrER, 1), UBound(WsArrER, 2) + 1) = WsArrER
With .Range("A4")
.Value = First
.Offset(1, 0).Value = First - 1
End With
.Range("A4:A5").AutoFill Destination:=.Range("A4").Resize(UBound(WsArrER, 1)), Type:= _
xlFillDefault
With .Range("JC5").Resize(First - 1, UBound(WsArrER, 2) + 1)
.FormulaLocal = "=WENN(SU6>$JB$3;WENN(SU50;0)))"
.Value = .Value
End With
With .Range("JC" & First + 5).Resize(Abs(Last), UBound(WsArrER, 2) + 1)
.FormulaLocal = "=WENN(SU" & First + 5 + 1 & "=$JB$2;$ _
A" & First + 5 & ";0);WENN(SU" & First + 5 + 1 & ">$JB$2;0;WENN(SUMME(JC" & First + 5 + 1 & ":JC$" & Abs(Last) + First + 5 & ")0;0)))"
.Value = .Value
End With
With .Range("IU4").Resize(UBound(WsArrER, 1))
.FormulaLocal = "=100/IY$5*IT4"
.Value = .Value
End With
.Columns.AutoFit
End With
'neuer Durchlauf mit neuen Tabellen "2"
With .Sheets("Grunddaten").Range("C1").CurrentRegion
WSarr = .Resize(.Rows.Count + 2).Value
End With
With .Sheets("Summieren2")
For Rl = LBound(WSarr, 1) + 1 To UBound(WSarr, 1) - 2 '' bisher 3
For C = LBound(WSarr, 2) To UBound(WSarr, 2)
WSarr(Rl, C) = WSarr(Rl, C) + WSarr(Rl + 1, C) + WSarr(Rl + 2, C) '' entfällt: + WSarr( _
Rl + 3, C)
If Maxist2  WSarr(Rl, C) Then Minist = WSarr(Rl, C)   'Minist2 neu benannt
Next
Next
.Columns("C:IS").Clear
.Range("C1").Resize(UBound(WSarr, 1), UBound(WSarr, 2)) = WSarr
.Range("IV2") = Maxist2
.Range("IV3") = Minist2
.Columns.AutoFit
End With
With .Sheets("ermitteln2")
First = Maxist2
Last = Minist2
ReDim WsArrER(First + Abs(Last) + 1, 251)  ' 10 bisher
For i = First To Last Step -1
For C = LBound(WSarr, 2) To UBound(WSarr, 2)
counter = 0
For Rl = LBound(WSarr, 1) + 1 To UBound(WSarr, 1) - 2
If WSarr(Rl, C) = i Then
counter = counter + 1
End If
Next
WsArrER(xx, UBound(WsArrER, 2)) = WsArrER(xx, UBound(WsArrER, 2)) + counter  ''  _
Fehlermeldung Index außerhalb des gültigen Bereichs ?
WsArrER(xx, C - 1) = counter
Next
xx = xx + 1
Next
' .UsedRange.Offset(0, 1).Clear
.Range("C4").Resize(UBound(WsArrER, 1), UBound(WsArrER, 2) + 1) = WsArrER
ReDim Preserve WsArrER(UBound(WsArrER, 1), UBound(WsArrER, 2) - 1)
For C = LBound(WsArrER, 2) To UBound(WsArrER, 2)
counter = 0
For xx = LBound(WsArrER, 1) To First - 1
counter = counter + WsArrER(xx, C)
WsArrER(xx, C) = counter
Next
Next
For C = LBound(WsArrER, 2) To UBound(WsArrER, 2)
counter = 0
For xx = UBound(WsArrER, 1) To First + 1 Step -1
counter = counter + WsArrER(xx, C)
WsArrER(xx, C) = counter
Next
Next
For C = LBound(WsArrER, 2) To UBound(WsArrER, 2)
WsArrER(First, C) = ""
Next
.Range("IZ2") = Maxist2
.Range("IZ3") = Minist2
.Range("SU4").Resize(UBound(WsArrER, 1), UBound(WsArrER, 2) + 1) = WsArrER
With .Range("A4")
.Value = First
.Offset(1, 0).Value = First - 1
End With
.Range("A4:A5").AutoFill Destination:=.Range("A4").Resize(UBound(WsArrER, 1)), Type:= _
xlFillDefault
With .Range("JC5").Resize(First - 1, UBound(WsArrER, 2) + 1)
.FormulaLocal = "=WENN(SU6>$JB$3;WENN(SU50;0)))"
.Value = .Value
End With
With .Range("JC" & First + 5).Resize(Abs(Last), UBound(WsArrER, 2) + 1)
.FormulaLocal = "=WENN(SU" & First + 5 + 1 & "=$JB$2;$ _
A" & First + 5 & ";0);WENN(SU" & First + 5 + 1 & ">$JB$2;0;WENN(SUMME(JC" & First + 5 + 1 & ":JC$" & Abs(Last) + First + 5 & ")0;0)))"
.Value = .Value
End With
With .Range("IU4").Resize(UBound(WsArrER, 1))
.FormulaLocal = "=100/IY$5*IT4"
.Value = .Value
End With
.Columns.AutoFit
End With
End With
End Sub

Besten Dank nochmal.
mfg

Formeln bzw. Lösung optimierbar?

Forumthread: Formeln bzw. Lösung optimierbar?

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Formeln bzw. Lösung optimierbar?

Forumthread: Formeln bzw. Lösung optimierbar?

23 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread