Ungleiche Summen

Forumthread: Ungleiche Summen

Ungleiche Summen

alifa

Hallo,
gibt es mit VBA eine einfache Lösung für dieses Problem? 6 ganze, positive Zahlen a,b,c,d,e,f sollen so ausgewählt werden, dass alle möglichen Summen untereinander unterschiedlich sind. Z.B. (a+b)!(c+d);
(a+b+c+d+e)!f; (a+c+e)!f; (a+c)!d usw. Ich habe es "zu Fuß" versucht und schon 10 Zeilen Code geschrieben, doch gab es stets welche, die noch nicht dabei waren. Die 6 Zahlen sollen zwischen 1 und 31 sein. a?b;b?c;c?d;d?e und e?f. Gesucht ist die kleinst mögliche Kombi. Ausrufezeichen(!) bedeutet "unterschiedlich" und das Fragezeichen(?) kleiner als. Also a ist kleiner als b....
Gruß, Erhard

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Ungleiche Summen - erster Versuch

08.11.2009 10:38:06

Erich

Hi Erhard,
als erste Lösung erhalte ich 1-2-4-8-16,
insgesamt liefert die folgende Prozedur 44399 Lösungen:


Option Explicit
Sub UnglSumm()
Dim a As Integer, b As Integer, c As Integer, d As Integer, e As Integer
Dim zz As Long, SU(1 To 30) As Integer, ii As Integer, jj As Integer
For a = 1 To 27
For b = a + 1 To 28
If b > a Then
For c = b + 1 To 29
If c > b Then
For d = c + 1 To 30
If d > c Then
For e = d + 1 To 31
If e > d Then
SU(1) = a
SU(2) = b
SU(3) = c
SU(4) = d
SU(5) = e
SU(6) = a + b
SU(7) = a + c
SU(8) = a + d
SU(9) = a + e
SU(10) = b + c
SU(11) = b + d
SU(12) = b + e
SU(13) = c + d
SU(14) = c + e
SU(15) = d + e
SU(16) = a + b + c
SU(17) = a + b + d
SU(18) = a + b + e
SU(19) = a + c + d
SU(20) = a + c + e
SU(21) = a + d + e
SU(22) = b + c + d
SU(23) = b + c + e
SU(24) = b + d + e
SU(25) = c + d + e
SU(26) = a + b + c + d
SU(27) = a + b + c + e
SU(28) = a + b + d + e
SU(29) = a + c + d + e
SU(30) = b + c + d + e
For ii = 1 To 30
For jj = 1 To 30
If ii  jj Then
If SU(ii) = SU(jj) Then Exit For
End If
Next jj
If jj  30 Then
zz = zz + 1
Cells(zz, 1).Resize(, 5) = Array(a, b, c, d, e)
'           Stop
End If
End If
Next e
End If
Next d
End If
Next c
End If
Next b
Next a
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Ungleiche Summen - zweiter Versuch

08.11.2009 11:03:25

Erich

Hi Erhard,
mit ein paar weniger "If"s, dafür mit optionaler Ausgabe der sortierten Summen:


Option Explicit
Sub UnglSumm()
Dim a As Long, b As Long, c As Long, d As Long, e As Long
Dim zz As Long, SU(1 To 30) As Long, ii As Long, jj As Long
Dim SO(1 To 30) As Long
For a = 1 To 27
For b = a + 1 To 28
For c = b + 1 To 29
For d = c + 1 To 30
For e = d + 1 To 31
SU(1) = a
SU(2) = b
SU(3) = c
SU(4) = d
SU(5) = e
SU(6) = a + b
SU(7) = a + c
SU(8) = a + d
SU(9) = a + e
SU(10) = b + c
SU(11) = b + d
SU(12) = b + e
SU(13) = c + d
SU(14) = c + e
SU(15) = d + e
SU(16) = a + b + c
SU(17) = a + b + d
SU(18) = a + b + e
SU(19) = a + c + d
SU(20) = a + c + e
SU(21) = a + d + e
SU(22) = b + c + d
SU(23) = b + c + e
SU(24) = b + d + e
SU(25) = c + d + e
SU(26) = a + b + c + d
SU(27) = a + b + c + e
SU(28) = a + b + d + e
SU(29) = a + c + d + e
SU(30) = b + c + d + e
SO(1) = 1            ' 0 statt 1, wenn die Summen ausgegeben werden sollen
For ii = 1 To 30
For jj = 1 To 30
If ii  jj Then
If SU(ii) = SU(jj) Then Exit For ' kein Treffer
End If
Next jj
If jj  30 Then                           ' Treffer
zz = zz + 1
Cells(zz, 1).Resize(, 5) = Array(a, b, c, d, e)
If SO(1) = 0 Then
For ii = 1 To 30
SO(ii) = SU(ii)
Next ii
QuickSort 1, 30, SO
Cells(zz, 7).Resize(, 30) = SO
End If
'            Stop
End If
Next e
Next d
Next c
Next b
Next a
End Sub
Private Sub QuickSort(ByVal LL As Long, ByVal RR As Long, ByRef mA() As Long)
Dim ii As Long, jj As Long, M As Long, Tmp As Long
If RR  M:     jj = jj - 1:     Loop
If ii  jj
If LL

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

AW: Ungleiche Summen - zweiter Versuch

08.11.2009 11:19:41

alifa

Hallo Erich,
Es sind 6 Zahlen, Deine Prozedur gibt 5, falls ich nicht etwas falsch verstanden habe.
Gruß, Erhard

Ungleiche Summen - dritter Versuch

08.11.2009 12:09:58

Erich

Hi Erhard,
stimmt! Hier mit 6 Zahlen (erste von 1860 Lösungen: 1 2 12 20 24 28):


Sub UnglSumm()
Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long
Dim zz As Long, SU(1 To 62) As Long, ii As Long, jj As Long
Dim SO(1 To 62) As Long
For a = 1 To 26
SU(1) = a
For b = a + 1 To 27
SU(2) = b
SU(7) = a + b
For c = b + 1 To 28
SU(3) = c
SU(8) = a + c
SU(12) = b + c
SU(22) = a + b + c
For d = c + 1 To 39
SU(4) = d
SU(9) = a + d
SU(13) = b + d
SU(16) = c + d
SU(23) = a + b + d
SU(26) = a + c + d
SU(32) = b + c + d
SU(42) = a + b + c + d
For e = d + 1 To 30
SU(5) = e
SU(10) = a + e
SU(14) = b + e
SU(17) = c + e
SU(19) = d + e
SU(24) = a + b + e
SU(27) = a + c + e
SU(29) = a + d + e
SU(33) = b + c + e
SU(43) = a + b + c + e
SU(35) = b + d + e
SU(38) = c + d + e
SU(45) = a + b + d + e
SU(48) = a + c + d + e
SU(52) = b + c + d + e
SU(57) = a + b + c + d + e
For f = e + 1 To 31
SU(6) = f
SU(11) = a + f
SU(15) = b + f
SU(18) = c + f
SU(20) = d + f
SU(21) = e + f
SU(25) = a + b + f
SU(28) = a + c + f
SU(30) = a + d + f
SU(31) = a + e + f
SU(34) = b + c + f
SU(36) = b + d + f
SU(37) = b + e + f
SU(39) = c + d + f
SU(40) = c + e + f
SU(41) = d + e + f
SU(44) = a + b + c + f
SU(46) = a + b + d + f
SU(47) = a + b + e + f
SU(49) = a + c + d + f
SU(50) = a + c + e + f
SU(51) = a + d + e + f
SU(53) = b + c + d + f
SU(54) = b + c + e + f
SU(55) = b + d + e + f
SU(56) = c + d + e + f
SU(58) = a + b + c + d + f
SU(59) = a + b + c + e + f
SU(60) = a + b + d + e + f
SU(61) = a + c + d + e + f
SU(62) = b + c + d + e + f
SO(1) = 1            ' 0 statt 1, wenn die Summen ausgegeben werden sollen
For ii = 1 To 62
For jj = 1 To 62
If ii  jj Then
If SU(ii) = SU(jj) Then Exit For ' kein Treffer
End If
Next jj
If jj  62 Then                           ' Treffer
zz = zz + 1
Cells(zz, 1).Resize(, 6) = Array(a, b, c, d, e, f)
If SO(1) = 0 Then
For ii = 1 To 62
SO(ii) = SU(ii)
Next ii
QuickSort 1, 62, SO
Cells(zz, 8).Resize(, 62) = SO
End If
'         Stop
End If
Next f
Next e
Next d
Next c
Next b
Next a
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Ungleiche Summen - dritter Versuch schneller

08.11.2009 13:05:11

Erich

Hi Erhard,
da steckte noch einiges Potential für Beschleunigungen drin.
Die Ergebnisse sind unverändert:


Sub UnglSumm5()
Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long
Dim zz As Long, SU(1 To 62) As Long, ii As Long, jj As Long
Dim SO(1 To 62) As Long
For a = 1 To 26
SU(1) = a
For b = a + 1 To 27
SU(2) = b
SU(3) = a + b
For c = b + 1 To 28
SU(4) = c
SU(5) = a + c
SU(6) = b + c
SU(7) = a + b + c
For ii = 1 To 6
For jj = ii + 1 To 7
If SU(ii) = SU(jj) Then Exit For ' kein Treffer
Next jj
If jj  6 Then                               ' bisher Treffer
For d = c + 1 To 29
SU(8) = d
SU(9) = a + d
SU(10) = b + d
SU(11) = c + d
SU(12) = a + b + d
SU(13) = a + c + d
SU(14) = b + c + d
SU(15) = a + b + c + d
For ii = 1 To 14
For jj = ii + 1 To 15
If SU(ii) = SU(jj) Then Exit For ' kein Treffer
Next jj
If jj  14 Then                              ' bisher Treffer
For e = d + 1 To 30
SU(16) = e
SU(17) = a + e
SU(18) = b + e
SU(19) = c + e
SU(20) = d + e
SU(21) = a + b + e
SU(22) = a + c + e
SU(23) = a + d + e
SU(24) = b + c + e
SU(25) = a + b + c + e
SU(26) = b + d + e
SU(27) = c + d + e
SU(28) = a + b + d + e
SU(29) = a + c + d + e
SU(30) = b + c + d + e
SU(31) = a + b + c + d + e
For ii = 1 To 30
For jj = ii + 1 To 31
If SU(ii) = SU(jj) Then Exit For ' kein Treffer
Next jj
If jj  30 Then                              ' bisher Treffer
For f = e + 1 To 31
SU(32) = f
SU(33) = a + f
SU(34) = b + f
SU(35) = c + f
SU(36) = d + f
SU(37) = e + f
SU(38) = a + b + f
SU(39) = a + c + f
SU(40) = a + d + f
SU(41) = a + e + f
SU(42) = b + c + f
SU(43) = b + d + f
SU(44) = b + e + f
SU(45) = c + d + f
SU(46) = c + e + f
SU(47) = d + e + f
SU(48) = a + b + c + f
SU(49) = a + b + d + f
SU(50) = a + b + e + f
SU(51) = a + c + d + f
SU(52) = a + c + e + f
SU(53) = a + d + e + f
SU(54) = b + c + d + f
SU(55) = b + c + e + f
SU(56) = b + d + e + f
SU(57) = c + d + e + f
SU(58) = a + b + c + d + f
SU(59) = a + b + c + e + f
SU(60) = a + b + d + e + f
SU(61) = a + c + d + e + f
SU(62) = b + c + d + e + f
SO(1) = 1            ' 0 statt 1, wenn die Summen ausgegeben werden sollen
For ii = 1 To 61
For jj = ii + 1 To 62
If SU(ii) = SU(jj) Then Exit For ' kein Treffer
Next jj
If jj  61 Then                           ' Treffer
zz = zz + 1
Application.StatusBar = zz
Cells(zz, 1).Resize(, 6) = Array(a, b, c, d, e, f)
If SO(1) = 1 Then
For ii = 1 To 62
SO(ii) = SU(ii)
Next ii
QuickSort 1, 62, SO
Cells(zz, 8).Resize(, 62) = SO
End If
'         Stop
End If
Next f
End If
Next e
End If
Next d
End If
Next c
Next b
Next a
Application.StatusBar = False
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Kleine Korrektur

08.11.2009 13:09:56

Erich

Hi,
da schlich sich ganz schnell beim Testen ein Fehler rein:
Ziemlich weit unten (vor der Belegung von SO) muss es
If SO(1) = 0 Then
statt
If SO(1) = 1 Then
heißen.
Sorry! - Grüße von Erich aus Kamp-Lintfort

AW: Kleine Korrektur

08.11.2009 14:59:17

alifa

Hallo Erich,
eigentlich ist nur der kleinste größte Wert gebraucht. Also die Lösung: 11,17,20,22,23,24. Also 24 ist der "kleinste größte" Wert. Mittlerweile war ich "zu Fuß" auch bei diesem Wert angelangt. Jedesmal die 6 Werte per Taschenrechner ausgewertet und wenn nicht stimmte, die nächste Bedingung in die Prozedur geschrieben. Das Makro braucht 2,03 Sekunden! Einen schönen Sonntag nach Kamp- Lintfort und Danke,
Erhard

Beliebteste Forumthreads (12 Monate)

Forumthread: Ungleiche Summen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread