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