vorläufige Optimierung
16.02.2017 14:16:12
Michael
Hallo Daniel,
vermutlich ist die Lösung rein mathematisch nicht befriedigend, aber sie kommt immerhin auf über 19.700 Erlös; mit den zufälligen Lösungen (Monte-Carlo-Algo) bin ich grad mal knapp über 18.500 gekommen.
Die Datei: https://www.herber.de/bbs/user/111524.xlsm
Das Makro:
Sub opti2a()
Const zv = 4
Dim zb& ' Zeile von/bis
Dim rZe, rz, sF, sE ' Zeile zum Einlesen, Rechnen, Spalte F, Spalte E
Dim sMax ' Kopie der Spalte F mit besten Ergebnissen
Dim GUph#, U18#, U19# ' # = as double
Dim i&, j&, k&, kj&
Dim sK$, aK, iK&
Dim weiter As Boolean
Dim t0 As Single
t0 = Timer
Application.ScreenUpdating = False
' Nebenbedingungen
GUph = Range("U12").Value: U18 = Range("U18").Value: U19 = Range("U19").Value
zb = Range("I" & Rows.Count).End(xlUp).Row
rZe = Range("A" & zv & ":P" & zv).Value
Range("F" & zv & ":F" & zb).Value = 1 ' mit 1 vorbelegt
sK = CStr(zv)
For i = zv To zb ' ***** Schleife 1 *****
If Range("E" & i) = 0.1126 And Range("E" & i + 1) = 0.0943 Then _
sK = sK & "," & i
If Range("F" & i) = 1 Then
If Range("O" & i).Value = 1 Then Range("F" & i).Value = 1
End If
Next
sK = sK & "," & CStr(zb)
' MsgBox sK
aK = Split(sK, ",") ' String in Array
For iK = 1 To UBound(aK) - 1 ' ***** Schleife 2 *****
' Stop
k = aK(iK) ' Zeilen-Nr. aus If in oberer For-Schleife
j = 0
weiter = True
' Range("H" & k).Interior.Color = vbGreen
While Range("H" & k) > -918 And weiter ' ***** Zahl noch optimieren
If k + j > aK(iK - 1) Then
Range("F" & k + j) = 1
' Range("F" & k + j).Interior.Color = vbYellow
j = j - 1
Else
weiter = False
End If
Wend
kj = k + j
' Stop
'j = j + 1
weiter = True
While Range("H" & k) aK(iK - 1) Then
Range("F" & k + j) = 0
' Range("F" & k + j).Interior.Color = vbGreen
j = j - 1
Else
weiter = False
End If
Wend
' Stop
For i = aK(iK - 1) + 1 To aK(iK + 1)
If Range("F" & i) = 1 Then
If Range("O" & i).Value = 1 Then Range("F" & i).Value = 1
End If
Next
Next
Range("X28").Value = Range("L1").Value
Range("X29").Value = (Timer - t0) * 1000 & " ms"
End Sub
Das Makro ist relativ langsam, weil ich während der Entwicklung nicht auf den Komfort verzichten wollte, Zellen zwischendrin einzufärben, um nachverfolgen zu können, was das Ding so treibt.
(dazu entfernst Du die Kommentarzeichen vor den "stop" und läßt den Code mit F8 zeilenweise bzw. F5 bis zum nächsten stop werkeln und verfolgst das in der Tabelle mit)
Die Varianten Opti2 und Opti2a sind soweit identisch, nur daß bei der a-Version die Färbung auskommentiert ist - das ist nochmal ein Geschwindigkeitsvorteil von rund 10%.
Im Prinzip funktioniert es so:
1. alle Zellen in F4-Fn werden mit 1 vorbelegt (um so viele Erträge wie möglich einzufahren)
2. in der 1. Schleife werden alle Tarifwechsel in einen String geschrieben, also "gemerkt"; außerdem werden die Randbedingungen "eingearbeitet".
3. vor der 2. Schleife wird der String in ein Array umgewandelt (split), das dann
4. in der 2. Schleife abgearbeitet wird.
Die Idee ist (je von unten nach oben):
a) vom Ende des "interessanten" Bereichs ausgehend werden so viele 1er in F geschrieben, bis der Wert in Spalte H kleiner als rund -980 (minus!) wird - das ist in etwa das, was max. mit 0en in den darüberliegenden Zellen kompensiert werden kann.
b) es werden anschließend so viele 0en geschrieben, bis der Wert über 80 liegt (dann kann mindestens)einmal entnommen werden.
c) am Anfang/Ende der beiden Bereiche bzw. bis zu ein, zwei Zeilen darunter und darüber kann es zu "falschen" 0 oder 1 kommen; um diese zu vermeiden, werden erneut die Randbedingungen überprüft.
Als "Auftrag" würde ich das Makro so nicht abliefern: es gehört sich schöner geschrieben (nicht benutzte Variablen entfernt usw.), optimiert (z.B. mit Array) und dokumentiert.
Aber für einen Forumsbeitrag hat es bereits genug Zeit verschlungen...
Schöne Grüße,
Michael