AW: Zeilen durchsuchen nach den am häufigsten Zahlen gemeinsam
10.08.2025 03:21:30
xlKing
Hi Tom,
Keine Ahnung, was jetzt Statistische Kombinatorik mit Vektoren zu tun haben soll. Das übersteigt selbst meine Kenntnis. Da ich mich aber grade mit Vektoren im Allgemeinen beschäftige, würde mich das in einem separaten Thread tatsächlich interessieren.
Ich würde jedoch ähnlich wie Daniel an die Sache rangehen und einfach ein paar Schleifen ineinander verschachteln. Das solltest selbst du mit VBA-Basiskenntnissen hinbekommen. Die Ergebnisse speichere ich in einem separaten Benutzerobjekt. Füge dazu ein neues Klassenmodul ein und gib ihm den Namen Results. Dort gibst du dann diesen Code an:
Public Values As New Collection
Public Available As Long
In einem allgemeinen Modul kannst du dann diesen Code ausführen:
Sub Ermitteln()
Dim Quelle As Range, Quelldaten, r As Long, c As Long, c1 As Long, c2 As Long, c3 As Long, c4 As Long, c5 As Long, s As String
Dim coll2er As New Collection, coll3er As New Collection, coll4er As New Collection, coll5er As New Collection
Dim Res2er() As Long, Res3er() As Long, Res4er() As Long, Res5er() As Long
Set Quelle = Worksheets("Tabelle1").Range("A1:G3000")
Quelldaten = Quelle
'2er ermitteln
For r = 1 To Quelle.Rows.Count
For c1 = 1 To Quelle.Columns.Count - 1
For c2 = c1 + 1 To Quelle.Columns.Count
s = Quelldaten(r, c1) & ";" & Quelldaten(r, c2)
If Not Exists(s, coll2er) Then
coll2er.Add New Results, s
coll2er(s).Values.Add Quelldaten(r, c1)
coll2er(s).Values.Add Quelldaten(r, c2)
End If
coll2er(s).Available = coll2er(s).Available + 1
Next c2
Next c1
Next r
'3er ermitteln
For r = 1 To Quelle.Rows.Count
For c1 = 1 To Quelle.Columns.Count - 2
For c2 = c1 + 1 To Quelle.Columns.Count - 1
For c3 = c2 + 1 To Quelle.Columns.Count
s = Quelldaten(r, c1) & ";" & Quelldaten(r, c2) & ";" & Quelldaten(r, c3)
If Not Exists(s, coll3er) Then
coll3er.Add New Results, s
coll3er(s).Values.Add Quelldaten(r, c1)
coll3er(s).Values.Add Quelldaten(r, c2)
coll3er(s).Values.Add Quelldaten(r, c3)
End If
coll3er(s).Available = coll3er(s).Available + 1
Next c3
Next c2
Next c1
Next r
'4er ermitteln
For r = 1 To Quelle.Rows.Count
For c1 = 1 To Quelle.Columns.Count - 3
For c2 = c1 + 1 To Quelle.Columns.Count - 2
For c3 = c2 + 1 To Quelle.Columns.Count - 1
For c4 = c3 + 1 To Quelle.Columns.Count
s = Quelldaten(r, c1) & ";" & Quelldaten(r, c2) & ";" & Quelldaten(r, c3) & ";" & Quelldaten(r, c4)
If Not Exists(s, coll4er) Then
coll4er.Add New Results, s
coll4er(s).Values.Add Quelldaten(r, c1)
coll4er(s).Values.Add Quelldaten(r, c2)
coll4er(s).Values.Add Quelldaten(r, c3)
coll4er(s).Values.Add Quelldaten(r, c4)
End If
coll4er(s).Available = coll4er(s).Available + 1
Next c4
Next c3
Next c2
Next c1
Next r
'5er ermitteln
For r = 1 To Quelle.Rows.Count
For c1 = 1 To Quelle.Columns.Count - 4
For c2 = c1 + 1 To Quelle.Columns.Count - 3
For c3 = c2 + 1 To Quelle.Columns.Count - 2
For c4 = c3 + 1 To Quelle.Columns.Count - 1
For c5 = c4 + 1 To Quelle.Columns.Count
s = Quelldaten(r, c1) & ";" & Quelldaten(r, c2) & ";" & Quelldaten(r, c3) & ";" & Quelldaten(r, c4) & ";" & Quelldaten(r, c5)
If Not Exists(s, coll5er) Then
coll5er.Add New Results, s
coll5er(s).Values.Add Quelldaten(r, c1)
coll5er(s).Values.Add Quelldaten(r, c2)
coll5er(s).Values.Add Quelldaten(r, c3)
coll5er(s).Values.Add Quelldaten(r, c4)
coll5er(s).Values.Add Quelldaten(r, c5)
End If
coll5er(s).Available = coll5er(s).Available + 1
Next c5
Next c4
Next c3
Next c2
Next c1
Next r
r = 0
With Worksheets.Add
'2er ausgeben
ReDim Res2er(1 To coll2er.Count, 1 To coll2er(1).Values.Count + 1) As Long
For r = 1 To coll2er.Count
For c = 1 To coll2er(r).Values.Count
Res2er(r, c) = coll2er(r).Values(c)
Next c
Res2er(r, c) = coll2er(r).Available
Next r
.Cells(1, 1).Resize(UBound(Res2er, 1), UBound(Res2er, 2)) = Res2er
.Range(.Cells(1, 1), .Cells(r - 1, c)).Sort Key1:=.Range(.Cells(1, c), .Cells(r - 1, c)), order1:=xlDescending
'3er ausgeben
ReDim Res3er(1 To coll3er.Count, 1 To coll3er(1).Values.Count + 1) As Long
For r = 1 To coll3er.Count
For c = 1 To coll3er(r).Values.Count
Res3er(r, c) = coll3er(r).Values(c)
Next c
Res3er(r, c) = coll3er(r).Available
Next r
.Cells(1, 5).Resize(UBound(Res3er, 1), UBound(Res3er, 2)) = Res3er
.Range(.Cells(1, 5), .Cells(r - 1, c + 4)).Sort Key1:=.Range(.Cells(1, c + 4), .Cells(r - 1, c + 4)), order1:=xlDescending
'4er ausgeben
ReDim Res4er(1 To coll4er.Count, 1 To coll4er(1).Values.Count + 1) As Long
For r = 1 To coll4er.Count
For c = 1 To coll4er(r).Values.Count
Res4er(r, c) = coll4er(r).Values(c)
Next c
Res4er(r, c) = coll4er(r).Available
Next r
.Cells(1, 10).Resize(UBound(Res4er, 1), UBound(Res4er, 2)) = Res4er
.Range(.Cells(1, 10), .Cells(r - 1, c + 9)).Sort Key1:=.Range(.Cells(1, c + 9), .Cells(r - 1, c + 9)), order1:=xlDescending
'5er ausgeben
ReDim Res5er(1 To coll5er.Count, 1 To coll5er(1).Values.Count + 1) As Long
For r = 1 To coll5er.Count
For c = 1 To coll5er(r).Values.Count
Res5er(r, c) = coll5er(r).Values(c)
Next c
Res5er(r, c) = coll5er(r).Available
Next r
.Cells(1, 16).Resize(UBound(Res5er, 1), UBound(Res5er, 2)) = Res5er
.Range(.Cells(1, 16), .Cells(r - 1, c + 15)).Sort Key1:=.Range(.Cells(1, c + 15), .Cells(r - 1, c + 15)), order1:=xlDescending
End With
MsgBox "Fertig"
End Sub
Je nach Geschwindigkeit deines Computers solltest du ihm schon ein bisschen Zeit (ca. 1-2 Minuten) für den Durchlauf geben. Am Ende kommt dann eine Fertig-Meldung.
Der Code legt ein neues Tabellenblatt an, wo du die Einzelnen Werte und deren Häufigkeit in absteigender Sortierung in separaten Spalten siehst.
PS: Solltest du mithilfe dieses Codes einen höheren Betrag gewinnen, hätt ich gern was davon ab. :-)
Gruß Mr. K.
