Ungleiche Summen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

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

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

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

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

Beliebteste Forumthreads (12 Monate)

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread