AW: Summanden in Ausgabe der Ergebnisse.
22.07.2015 18:34:33
Daniel
Hi
geht auch.
für sowas bietet sich das Dictionary-Objekt zur Duplikatsvermeidung an.
Die Einzelergebnisse müssen natürlich sortiert werden.
die von mir hier gewählte, etwas unkonventionelle Sortier methode funktioniert so nur bei Ganzzahlen und wenn innerhalb einer Gruppe keine Duplikate vorkommen.
Sub testTeilsumme()
[e:h].ClearContents
Dim h1, h2, h3, h4, h5
Dim z&, p, p4, p5, p6, p7
Dim dicErg
Dim Sort
Set dicErg = CreateObject("scripting.Dictionary")
p4 = Array(9, 11, 14, 16, 17, 18, 19, 22, 23, 25, 26, 27, 28, 29, 30, 31, _
34, 35, 36, 37, 39, 41, 42, 43, 44, 45, 46, 47, 48, 50, 52, 55) 'h2
p5 = Array(9, 14, 16, 17, 18, 21, 22, 26, 27, 28, 29, 30, 31, _
34, 35, 36, 37, 41, 42, 45, 46, 47, 48, 50, 51, 52, 55) 'h3
p6 = Array(9, 10, 11, 14, 16, 17, 18, 23, 26, 28, 30, 32, _
34, 35, 36, 37, 38, 39, 42, 43, 45, 46, 50, 52) 'h4
p7 = Array(10, 11, 13, 14, 16, 18, 19, 21, 22, 23, 25, 27, 28, 29, 30, _
33, 34, 36, 38, 39, 40, 41, 45, 46, 47, 50, 52, 55) 'h5
For Each h2 In p4
For Each h3 In p5
If h3 h2 Then
For Each h4 In p6
If h4 h3 And h4 h2 Then
For Each h5 In p7
If h5 h4 And h5 h3 And h5 h2 Then
If h2 + h3 + h4 + h5 = 115 Then
z = z + 1
If z = 1000 Then GoTo Ausgabe
ReDim Sort(1 To 99)
Sort(h2) = h2
Sort(h3) = h3
Sort(h4) = h4
Sort(h5) = h5
dicErg(WorksheetFunction.Trim(Join(Sort, " "))) = 1
End If: End If: Next: End If: Next: End If: Next: Next
Ausgabe:
With Cells(1, 5).Resize(dicErg.Count, 1)
.Value = WorksheetFunction.Transpose(dicErg.keys)
.TextToColumns Destination:=.Cells(1, 1), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, _
Space:=True
End With
End Sub
Gruß Daniel