AW: VBA Lösung
01.09.2018 13:07:49
Matthias
Und noch eine Ergänzung. Da war noch ein kleiner Fehler drin. Zudem werden die Werte jetzt der Größe nach angegeben und sortiert. Ist jetzt auch etwas schneller.
Sub kombinationen()
Dim daten
Dim zeile As Long
Dim tzeile As Long
Dim ttzeile As Long
Dim spalt As Long
Dim datrow As Long
Dim datcol As Long
Dim zahlen As Object
Dim alle2 As Object
Dim alle3 As Object
Dim treffer2 As Object
Dim treffer3 As Object
Set zahlen = CreateObject("Scripting.Dictionary")
Set treffer2 = CreateObject("Scripting.Dictionary")
Set alle2 = CreateObject("Scripting.Dictionary")
Set treffer3 = CreateObject("Scripting.Dictionary")
Set alle3 = CreateObject("Scripting.Dictionary")
daten = Tabelle1.Range("K3:Q10")
datrow = UBound(daten, 1)
datcol = UBound(daten, 2)
For spalte = 1 To datcol
For zeile = 1 To datrow
If Not zahlen.exists(daten(zeile, spalte)) Then zahlen.Add (daten(zeile, spalte)), _
String(datcol, "0")
zahlen(daten(zeile, spalte)) = Left(zahlen(daten(zeile, spalte)), spalte - 1) & "1" _
& Right(zahlen(daten(zeile, spalte)), datcol - spalte)
Next zeile
Next spalte
For zeile = 0 To zahlen.Count - 1
For tzeile = zeile + 1 To zahlen.Count - 1
If prüfung(zahlen.items()(zeile), zahlen.items()(tzeile), datcol) Then
If Not alle2.exists((zahlen.keys()(zeile) & " - " & zahlen.keys()(tzeile))) Then
treffer2.Add sortieren((zahlen.keys()(zeile) & " - " & zahlen.keys()(tzeile)), _
2), 1
alle2.Add (zahlen.keys()(zeile) & " - " & zahlen.keys()(tzeile)), 1
alle2.Add (zahlen.keys()(tzeile) & " - " & zahlen.keys()(zeile)), 1
End If
End If
For ttzeile = tzeile + 1 To zahlen.Count - 1
If prüfung2(zahlen.items()(zeile), zahlen.items()(tzeile), zahlen.items()(ttzeile), _
datcol) Then
If Not alle3.exists((zahlen.keys()(zeile) & " - " & zahlen.keys()(tzeile) & " - _
" & zahlen.keys()(ttzeile))) Then
treffer3.Add sortieren((zahlen.keys()(zeile) & " - " & zahlen.keys()(tzeile) _
& " - " & zahlen.keys()(ttzeile)), 3), 1
alle3.Item(zahlen.keys()(zeile) & " - " & zahlen.keys()(tzeile) & " - " & _
zahlen.keys()(ttzeile)) = 1
alle3.Item(zahlen.keys()(zeile) & " - " & zahlen.keys()(ttzeile) & " - " & _
zahlen.keys()(tzeile)) = 1
alle3.Item(zahlen.keys()(tzeile) & " - " & zahlen.keys()(zeile) & " - " & _
zahlen.keys()(ttzeile)) = 1
alle3.Item(zahlen.keys()(tzeile) & " - " & zahlen.keys()(ttzeile) & " - " & _
zahlen.keys()(zeile)) = 1
alle3.Item(zahlen.keys()(ttzeile) & " - " & zahlen.keys()(zeile) & " - " & _
zahlen.keys()(tzeile)) = 1
alle3.Item(zahlen.keys()(ttzeile) & " - " & zahlen.keys()(tzeile) & " - " & _
zahlen.keys()(zeile)) = 1
End If
End If
Next
Next
Next
Tabelle2.Columns("A:B").ClearContents
Tabelle2.Cells(1, 1) = "Lösung für Double"
Tabelle2.Cells(2, 1).Resize(treffer2.Count) = Application.WorksheetFunction.Transpose(treffer2. _
keys)
If treffer2.Count > 1 Then Tabelle2.Cells(2, 1).Resize(treffer2.Count).Sort Key1:=Tabelle2. _
Range("A2"), Order1:=xlAscending, Header:=xlGuess, Orientation:=xlTopToBottom
Tabelle2.Cells(1, 2) = "Lösung für Tripple"
Tabelle2.Cells(2, 2).Resize(treffer3.Count) = Application.WorksheetFunction.Transpose(treffer3. _
keys)
If treffer3.Count > 1 Then Tabelle2.Cells(2, 2).Resize(treffer3.Count).Sort Key1:=Tabelle2. _
Range("B2"), Order1:=xlAscending, Header:=xlGuess, Orientation:=xlTopToBottom
End Sub
Function prüfung(ByVal text1 As String, ByVal text2 As String, anzahl As Long) As Boolean
Dim stelle As Long
prüfung = True
For stelle = 1 To anzahl
If Mid(text1, stelle, 1) = 0 And Mid(text2, stelle, 1) = 0 Then
prüfung = False
Exit Function
End If
Next
End Function
Function prüfung2(ByVal text1 As String, ByVal text2 As String, ByVal text3 As String, anzahl _
As Long) As Boolean
Dim stelle As Long
prüfung2 = True
For stelle = 1 To anzahl
If Mid(text1, stelle, 1) = 0 And Mid(text2, stelle, 1) = 0 And Mid(text3, stelle, 1) = 0 _
Then
prüfung2 = False
Exit Function
End If
Next
End Function
Function sortieren(ByVal text As String, stellen As Long) As String
Dim temp
Dim i As Long
Dim werte
temp = Split(text, " - ")
If stellen = 2 Then
If temp(0) > temp(1) Then text = temp(1) & " - " & temp(0)
Else
ReDim werte(1 To 3)
For i = 0 To 2
werte(i + 1) = CLng(temp(i))
Next
text = Application.WorksheetFunction.Small(werte, 1) & " - " & Application. _
WorksheetFunction.Small(werte, 2) & " - " & Application.WorksheetFunction.Small(werte, 3)
End If
sortieren = text
End Function