Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1072to1076
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Umgehung eines nicht lösbaren Solver-Problems

Umgehung eines nicht lösbaren Solver-Problems
08.05.2009 11:51:42
Hoof
Hallo liebe Herber-Gemeinde,
ich stehe vor folgendem Problem:
Ich habe ein nicht konvergentes Solver-Problem mit 16 veränderbaren Zellen. Ich möchte eine vorgegebene Zielzelle maximieren. Der Solver schafft dies nicht, da es keine konstanten Zusammenhänge zwischen den veränderbaren Zellen gibt. Sprich die Erhöhung einesw Faktors ist bis zu einem bestimmten Punkt positiv, dann negativ, und wenn ich ihn in Kombination zu einem anderen Faktor setze ist es möglicherweise komplett andersherum.
So viel zum Ausgangsproblem...das ist jedoch für meine Frage eigentlich nicht relevant! =)
Ich möchte nun via VBA programmieren, dass alle möglichen Kombinationen der 16 Zellen nacheinander eingesetzt werden, dadurch verändert sich automatisch mein Zielwert, sofern dieser dann höher ist als der davor wird die Kombination überschrieben. Also keine Optimierung sondern ein Ausprobieren aller Möglichkeiten.
Dabei gelten folgende Restriktionen:
Die Iterationsschritte für jede einzelne Zelle liegen bei 0,05 und der Wert darf alles zwischen 0 und 0,5 annehmen. Im besten Fall mit einer Summenbegrenzung, so dass alle Zellen zusammen einen Wert von 1 haben (100% halt), dies ist allerdings nicht unbedingt notwendig, wäre aber nett.
Mir fehlt bei diesem Problem leider völlig der Lösungsansatz, und ich befürchte, dass meine VBA - Kenntnisse dafür nicht ausreichen.
Ich bin also für jede Hilfestellung dankbar.
Viele Grüße Hoof

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Auf die ganz dumme Art...
08.05.2009 13:20:23
Harald
Hallo Hoof,
ganz dumm lässt sich das mit Schleifen über alle Werte lösen. Ich habe das als Beispiel mal für 3 Variable programmiert, kannst Du leicht auf 16 variable aufbohren, aber koch' schon mal Kaffee...

Sub test()
Dim Ergebnis As Double
Dim Zwischenergebnis As Double
Dim Z1 As Double
Dim Z2 As Double
Dim Z3 As Double
' hier bis Z16 zu erweitern
Const MinDouble = -1.79769313486231E+308
Ergebnis = MinDouble
For Z1 = 0 To 4.5 Step 0.5
For Z2 = 0 To 4.5 Step 0.5
For Z3 = 0 To 4.5 Step 0.5 'hier weitere Schleifen bis Z16 schachteln
Zwischenergebnis = formel(Z1, Z2, Z3)
If Zwischenergebnis > Ergebnis Then
Ergebnis = Zwischenergebnis
End If
Next
Next
Next
Range("A1") = Z1 'angenommen die Ergebnisse sollen in A1...A3 stehen, auch hier bis Z16 / A16  _
zu erweitern
Range("A2") = Z2
Range("A3") = Z3
Range("B1") = Ergebnis ' angenommen Zielzelle für das Ergebnis ist B1
End Sub



Function formel(A As Double, B As Double, C As Double) ' auf 16 Variable zu erweitern
formel = (A * B) + Sin(C) 'hier Deine benutzerdefinierte zu optimierende Funktion einbauen
End Function


Sorry, hab' leider keine Zeit, Dein Problem voll durchzuprogrammieren, hoffe der Ansatz genügt.
Harald

Anzeige
AW: Auf die ganz dumme Art...
08.05.2009 14:15:27
Hoof
So, ich habe das Problem jetzt auf folgende Weise umgesetzt, und es funktioniert auch einwandfrei. Das es extrem lange dauert ist kein Problem...es soll eh nur alle 2 Monate durchlaufen.
Hier meine Umsetzung:

Sub AlleKombinationen()
Dim Ergebnis As Double
Dim Zwischenergebnis As Double
Dim Z1 As Double
Dim Z2 As Double
Dim Z3 As Double
Dim z4 As Double
Dim z5 As Double
Dim z6 As Double
Dim z7 As Double
Dim z8 As Double
Dim z9 As Double
Dim z10 As Double
Dim z11 As Double
Dim z12 As Double
Dim z13 As Double
Dim z14 As Double
Dim z15 As Double
Dim z16 As Double
For Z1 = 0 To 0.4 Step 0.05
For Z2 = 0 To 0.4 Step 0.05
For Z3 = 0 To 0.4 Step 0.05
For z4 = 0 To 0.4 Step 0.05
For z5 = 0 To 0.4 Step 0.05
For z6 = 0 To 0.4 Step 0.05
For z7 = 0 To 0.4 Step 0.05
For z8 = 0 To 0.4 Step 0.05
For z9 = 0 To 0.4 Step 0.05
For z10 = 0 To 0.4 Step 0.05
For z11 = 0 To 0.4 Step 0.05
For z12 = 0 To 0.4 Step 0.05
For z13 = 0 To 0.4 Step 0.05
For z14 = 0 To 0.4 Step 0.05
For z15 = 0 To 0.4 Step 0.05
For z16 = 0 To 0.4 Step 0.05
Sheets("Tabelle2").Select
Range("B3") = Z1
Range("B4") = Z2
Range("B5") = Z3
Range("B6") = z4
Range("B7") = z5
Range("B8") = z6
Range("B9") = z7
Range("B10") = z8
Range("B11") = z9
Range("B12") = z10
Range("B13") = z11
Range("B14") = z12
Range("B15") = z13
Range("B16") = z14
Range("B17") = z15
Range("B18") = z16
Zwischenergebnis = Cells(23, 2)
Ergebnis = Cells(32, 2)
If Zwischenergebnis > Ergebnis Then
Range("B23").Select
Selection.Copy
Range("B32").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks  _
_
:=False, Transpose:=False
End If
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
End Sub


Soweit so gut...gibt es irgendeine Möglichkeit eine zusätzliche Restriktion in der Form einzubauen, dass nur die Möglichkeiten durchlaufen werden, bei denen die Summe der 16 Zellen =1 ist?
(Für den normalen Solver hatte ich eine Summenzelle der 16 Gewichte die =1 sein musste)
Tausend Dank schon mal...

Anzeige
AW: Auf die ganz dumme Art...
08.05.2009 14:16:33
Hoof
Achso, eine zusätzliche Formel für die Zielzelle benötige ich nicht, dies wird über Verknüpfungen automatisch bei jeder neuen Kombination angepasst...
AW: Umgehung eines nicht lösbaren Solver-Problems
08.05.2009 13:21:12
Wolli
Hallo Hoof,
Du hast für jede Zelle 21 Eingabemöglichkeiten, das gibt 21^16 = 1,4 Billiarden Möglichkeiten - ein zusätzlicher Algorithmus für die Begrenzung der Eingabe ist also unerlässlich. Stichwort Suchbaum und so.
Das außer Acht gelassen, ist die Programmierung eigentlich leicht: Nimm eine 16fach verschachtelte for-next-Schleife nach dem Muster

for i = 0 to 0.5 step 0.05
for j = 0 to 0.5 step 0.05
for k = 0 to 0.5 step 0.05
'setze i, j, k, ... ein
'prüfe / speichere Ergebnis
next k
next j
next i


Aber wie gesagt - wichtiger ist eine logische Eingrenzung der möglichen Eingaben.
So viel von mir, die Frage bleibt offen. Gruß, Wolli

Anzeige
AW: Umgehung eines nicht lösbaren Solver-Problems
08.05.2009 13:32:36
Hoof
Vielen Dank für eure schnellen Antworten, ich werde mal schauen wie weit ich mit der vorgeschlagenen Schleife komme.
Werde die Zellen mal auf 0 bis 0,4 begrenzen...
also 0; 0,05; 0,1; 0,15; 0,2; 0,25; 0,3; 0,35; 0,4
dann bin ich bei 9^16= immer noch zu viel aber mal schauen =)
Melde mich bestimmt nochmal! =)
AW: Umgehung eines nicht lösbaren Solver-Problems
08.05.2009 13:40:39
Harald
Man könnte natürlich auch mal gucken, ob man mit klassicher Kurvendiskussion/Extremwertsuche per Ableitung der Zielformel und Nullstellensuche nicht schneller ans Ziel kommt...
Harald
AW: Umgehung eines nicht lösbaren Solver-Problems
08.05.2009 14:18:42
Hoof
Hoppla ...Antworten stehen oben! =) bin noch neu hier! =)
Austiegsbedingungen schaffen...
08.05.2009 14:55:12
ransi
HAllo
Man darf die Schleifen nicht bis zum Ende durchlaufen.
Mal als Ansatz zum Weiterbasteln:
Option Explicit


Public Sub t()
Const s As Single = 0.05

Const Z As Single = 0.5
Dim arr(1 To 16)
Dim a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q
Dim myDic As Object
Set myDic = CreateObject("Scripting.Dictionary")
For a = 0 To Z Step s
    arr(1) = a
    Select Case WorksheetFunction.Sum(arr)
        Case Is > 1.06:
            arr(1) = 0
            Exit For
        Case Is > 0.96:
            myDic(Join(arr, " +")) = 0
    End Select
    For b = 0 To Z Step s
        arr(2) = b
        Select Case WorksheetFunction.Sum(arr)
            Case Is > 1.06:
                arr(2) = 0
                Exit For
            Case Is > 0.96: myDic(Join(arr, " +")) = 0
        End Select
        For c = 0 To Z Step s
            arr(3) = c
            Select Case WorksheetFunction.Sum(arr)
                Case Is > 1.06:
                    arr(3) = 0
                    Exit For
                Case Is > 0.96: myDic(Join(arr, " +")) = 0
            End Select
            For d = 0 To Z Step s
                arr(4) = d
                Select Case WorksheetFunction.Sum(arr)
                    Case Is > 1.06:
                        arr(4) = 0
                        Exit For
                    Case Is > 0.96: myDic(Join(arr, " +")) = 0
                End Select
                For e = 0 To Z Step s
                    arr(5) = e
                    Select Case WorksheetFunction.Sum(arr)
                        Case Is > 1.06:
                            arr(5) = 0
                            Exit For
                        Case Is > 0.96: myDic(Join(arr, " +")) = 0
                    End Select
                    For f = 0 To Z Step s
                        arr(6) = f
                        Select Case WorksheetFunction.Sum(arr)
                            Case Is > 1.06:
                                arr(6) = 0
                                Exit For
                            Case Is > 0.96: myDic(Join(arr, " +")) = 0
                        End Select
                        For g = 0 To Z Step s
                            arr(7) = g
                            Select Case WorksheetFunction.Sum(arr)
                                Case Is > 1.06:
                                    arr(7) = 0
                                    Exit For
                                Case Is > 0.96: myDic(Join(arr, " +")) = 0
                            End Select
                            For h = 0 To Z Step s
                                arr(8) = h
                                Select Case WorksheetFunction.Sum(arr)
                                    Case Is > 1.06:
                                        arr(8) = 0
                                        Exit For
                                    Case Is > 0.96: myDic(Join(arr, " +")) = 0
                                End Select
                                For i = 0 To Z Step s
                                    arr(9) = i
                                    Select Case WorksheetFunction.Sum(arr)
                                        Case Is > 1.06:
                                            arr(9) = 0
                                            Exit For
                                        Case Is > 0.96: myDic(Join(arr, " +")) = 0
                                    End Select
                                    For j = 0 To Z Step s
                                        arr(10) = j
                                        Select Case WorksheetFunction.Sum(arr)
                                            Case Is > 1.06:
                                                arr(10) = 0
                                                Exit For
                                            Case Is > 1: myDic(Join(arr, " +")) = 0
                                        End Select
                                        For k = 0 To Z Step s
                                            arr(11) = k
                                            Select Case WorksheetFunction.Sum(arr)
                                                Case Is > 1.06:
                                                    arr(11) = 0
                                                    Exit For
                                                Case Is > 0.96: myDic(Join(arr, " +")) = 0
                                            End Select
                                            For l = 0 To Z Step s
                                                arr(12) = l
                                                Select Case WorksheetFunction.Sum(arr)
                                                    Case Is > 1.06:
                                                        arr(12) = 0
                                                        Exit For
                                                    Case Is > 0.96: myDic(Join(arr, " +")) = 0
                                                End Select
                                                For m = 0 To Z Step s
                                                    arr(13) = m
                                                    Select Case WorksheetFunction.Sum(arr)
                                                        Case Is > 1.06:
                                                            arr(13) = 0
                                                            Exit For
                                                        Case Is > 0.96: myDic(Join(arr, " +")) = 0
                                                    End Select
                                                    For n = 0 To Z Step s
                                                        arr(14) = n
                                                        Select Case WorksheetFunction.Sum(arr)
                                                            Case Is > 1.06:
                                                                arr(14) = 0
                                                                Exit For
                                                            Case Is > 0.96: myDic(Join(arr, " +")) = 0
                                                        End Select
                                                        For o = 0 To Z Step s
                                                            arr(15) = o
                                                            Select Case WorksheetFunction.Sum(arr)
                                                                Case Is > 1.06:
                                                                    arr(15) = 0
                                                                    Exit For
                                                                Case Is > 0.96: myDic(Join(arr, " +")) = 0
                                                            End Select
                                                            For p = 0 To Z Step s
                                                                arr(16) = p
                                                                Select Case WorksheetFunction.Sum(arr)
                                                                    Case Is > 1.06:
                                                                        arr(16) = 0
                                                                        Exit For
                                                                    Case Is > 0.96:
                                                                        myDic(Join(arr, " +")) = 0
                                                                End Select
                                                            Next
                                                        Next
                                                    Next
                                                Next
                                            Next
                                        Next
                                    Next
                                Next
                            Next
                        Next
                    Next
                Next
            Next
        Next
    Next
Next
Range("a1").Resize(myDic.Count) = WorksheetFunction.Transpose(myDic.keys)
End Sub

ransi
Anzeige
AW: Austiegsbedingungen schaffen...
08.05.2009 15:31:54
Hoof
Super, vielen vielen Dank, damit kann ich glaub ich sehr gut weiterarbeiten, auch wenn ich nicht alles zu 100% verstehe! =)
Hast du vlt. auch eine Idee ob es möglich wäre nur Kombinationen zu testen bei denen die Summe der 16 Zellen =1 ist?
Gruß Hoof
AW: Austiegsbedingungen schaffen...
08.05.2009 16:14:13
Hoof
Sooo, hier nun also meine Umsetzung und die Probleme die ich noch habe: =)
Option Explicit

Sub AlleKombinationen()
Dim Ergebnis As Single
Dim Zwischenergebnis As Single
Dim Z1 As Single
Dim Z2 As Single
Dim Z3 As Single
Dim z4 As Single
Dim z5 As Single
Dim z6 As Single
Dim z7 As Single
Dim z8 As Single
Dim z9 As Single
Dim z10 As Single
Dim z11 As Single
Dim z12 As Single
Dim z13 As Single
Dim z14 As Single
Dim z15 As Single
Dim z16 As Single
Dim arr(1 To 16)
Dim myDic As Object
Set myDic = CreateObject("Scripting.Dictionary")
'Application.ScreenUpdating = False
For z16 = 0 To 0.4 Step 0.1
arr(1) = z16
Select Case WorksheetFunction.Sum(arr)
Case Is > 1.06:
arr(1) = 0
Exit For
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
End Select
For z15 = 0 To 0.4 Step 0.1
arr(2) = z15
Select Case WorksheetFunction.Sum(arr)
Case Is > 1.06:
arr(2) = 0
Exit For
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
End Select
For z14 = 0 To 0.4 Step 0.1
arr(3) = z14
Select Case WorksheetFunction.Sum(arr)
Case Is > 1.06:
arr(3) = 0
Exit For
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
End Select
For z13 = 0 To 0.4 Step 0.1
arr(4) = z13
Select Case WorksheetFunction.Sum(arr)
Case Is > 1.06:
arr(4) = 0
Exit For
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
End Select
For z12 = 0 To 0.4 Step 0.1
arr(5) = z12
Select Case WorksheetFunction.Sum(arr)
Case Is > 1.06:
arr(5) = 0
Exit For
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
End Select
For z11 = 0 To 0.4 Step 0.1
arr(6) = z11
Select Case WorksheetFunction.Sum(arr)
Case Is > 1.06:
arr(6) = 0
Exit For
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
End Select
For z10 = 0 To 0.4 Step 0.1
arr(7) = z10
Select Case WorksheetFunction.Sum(arr)
Case Is > 1.06:
arr(7) = 0
Exit For
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
End Select
For z9 = 0 To 0.4 Step 0.1
arr(8) = z9
Select Case WorksheetFunction.Sum(arr)
Case Is > 1.06:
arr(8) = 0
Exit For
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
End Select
For z8 = 0 To 0.4 Step 0.1
arr(9) = z8
Select Case WorksheetFunction.Sum(arr)
Case Is > 1.06:
arr(9) = 0
Exit For
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
End Select
For z7 = 0 To 0.4 Step 0.1
arr(10) = z7
Select Case WorksheetFunction.Sum(arr)
Case Is > 1.06:
arr(10) = 0
Exit For
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
End Select
For z6 = 0 To 0.4 Step 0.1
arr(11) = z6
Select Case WorksheetFunction.Sum(arr)
Case Is > 1.06:
arr(11) = 0
Exit For
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
End Select
For z5 = 0 To 0.4 Step 0.1
arr(12) = z5
Select Case WorksheetFunction.Sum(arr)
Case Is > 1.06:
arr(12) = 0
Exit For
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
End Select
For z4 = 0 To 0.4 Step 0.1
arr(13) = z4
Select Case WorksheetFunction.Sum(arr)
Case Is > 1.06:
arr(13) = 0
Exit For
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
End Select
For Z3 = 0 To 0.4 Step 0.1
arr(14) = Z3
Select Case WorksheetFunction.Sum(arr)
Case Is > 1.06:
arr(14) = 0
Exit For
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
End Select
For Z2 = 0 To 0.4 Step 0.1
arr(15) = Z2
Select Case WorksheetFunction.Sum(arr)
Case Is > 1.06:
arr(15) = 0
Exit For
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
End Select
For Z1 = 0 To 0.4 Step 0.1
arr(16) = Z1
Select Case WorksheetFunction.Sum( _
arr)
Case Is > 1.06:
arr(16) = 0
Exit For
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
End Select
Sheets("Tabelle2").Select
Range("B3") = Z1
Range("B4") = Z2
Range("B5") = Z3
Range("B6") = z4
Range("B7") = z5
Range("B8") = z6
Range("B9") = z7
Range("B10") = z8
Range("B11") = z9
Range("B12") = z10
Range("B13") = z11
Range("B14") = z12
Range("B15") = z13
Range("B16") = z14
Range("B17") = z15
Range("B18") = z16
Zwischenergebnis = Cells(23, 2)
Ergebnis = Cells(32, 2)
If Zwischenergebnis > Ergebnis Then
Range("B23").Select
Selection.Copy
Range("B32").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks  _
_
:=False, Transpose:=False
Range("A3:B18").Select
Selection.Copy
Range("C32").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks  _
_
:=False, Transpose:=False
Application.CutCopyMode = False
End If
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
End Sub


Damit ich selbst weiterbasteln kann, wäre es super wenn du mir noch einmal erklärst was genau durch
Case Is > 0.96:
myDic(Join(arr, " +")) = 0
passiert!
Als Feedback zum jetzigen Code: Er variiert die ersten 3 Zellen bis max. 0,3 (?), läuft diese immer wieder durch und kombiniert dazu immer eine der weiteren zellen mit 0,1 gewicht, variiert diese aber leider nicht mehr...
Nochmals vielen Dank, bin begeistert über die schnelle Hilfe!
PS: Meine nächste Reaktion wird erst am Montag kommen.

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige