4 Spalten mit geringster Schnittmenge an Werten auswählen

[Ego]

Hallo Thea,

falls du auf ein Endergebnis wartest, hier das leicht modifizierte Makro von Fennek:

Code:

Option Explicit
Option Base 1

Private Sub cbBerechnen_Click()

Dim intI As Integer
Dim intJ As Integer
Dim intK As Integer
Dim intL As Integer
Dim intO As Integer
Dim intWert As Integer
Dim varMax(5) As Variant
Dim intDummy As Integer
Dim dblAnfang As Double
Dim varDaten As Variant

dblAnfang = Timer
varDaten = Range("A1:AY375")
varMax(1) = 0
With CreateObject("scripting.dictionary")
For intI = 1 To 51 - 3
    For intJ = intI + 1 To 51 - 2
        For intK = intJ + 1 To 51 - 1
            For intL = intK + 1 To 51
                For intO = 1 To 375
                    intWert = varDaten(intO, intI)
                    intDummy = .Item(intWert)
                Next intO
                For intO = 1 To 375
                intWert = varDaten(intO, intJ)
                    intDummy = .Item(intWert)
                Next intO
                For intO = 1 To 375
                intWert = varDaten(intO, intK)
                    intDummy = .Item(intWert)
                Next intO
                For intO = 1 To 375
                intWert = varDaten(intO, intL)
                    intDummy = .Item(intWert)
                Next intO
                If .Count > varMax(1) Then
                    varMax(1) = .Count
                    varMax(2) = intI
                    varMax(3) = intJ
                    varMax(4) = intK
                    varMax(5) = intL
                End If
                .RemoveAll
            Next intL
        Next intK
   Next intJ
Next intI
End With
Range("a381:E381") = varMax
MsgBox (Timer - dblAnfang) & " Sekunden"

End Sub

und die Datei im Anhang. Achtung! Auf meinem Rechner benötigt die Berechnung ca 7 Minuten.

[Fennek]

@ Ego

gute Arbeit!

[Fennek]

Hallo,

nachdem Ego meine beliebte Kopfrechnung (4 über 51 ist unendlich, Laufzeit für alle Varianten dauert unendlich) widerlegt hat, sah ich mir das Thema noch einmal an.

Findings:
- Ich konnte mit Arrays kein "countif()" rechnen
- ich konnte nicht 2 Arrays verknüpfen

Deshalb der Rückgriff auf Dictionary:

Code:

Sub T1()
Anf = Timer
Dim Erg(4)
Dim Res(4 * 375)

F0 = Sheets("Ori").Cells(1).CurrentRegion
With CreateObject("scripting.dictionary")
For j0 = 1 To UBound(F0, 2) - 3
   For i = 1 To UBound(F0)
       Res(i + 0 * UBound(F0)) = F0(i, j0)
   Next i
For j1 = j0 + 1 To UBound(F0, 2) - 2
   For i = 1 To UBound(F0)
       Res(i + 1 * UBound(F0)) = F0(i, j1)
   Next i
For j2 = j1 + 1 To UBound(F0, 2) - 1
   For i = 1 To UBound(F0)
       Res(i + 2 * UBound(F0)) = F0(i, j2)
   Next i
For j3 = j2 + 1 To UBound(F0, 2)
   For i = 1 To UBound(F0)
       Res(i + 3 * UBound(F0)) = F0(i, j3)
   Next i
   For i = 1 To UBound(Res)
       If Not .exists(Res(i)) Then y = .Item(Res(i))
   Next

   If .Count > Erg(0) Then
       Erg(0) = .Count
       Erg(1) = j0
       Erg(2) = j1
       Erg(3) = j2
       Erg(4) = j3
       Debug.Print Timer - Anf, .Count, j0, j1, j2, j3
   End If
.RemoveAll
Next j3
Next j2
Next j1
Debug.Print Timer - Anf, j0
Next j0
Debug.Print Timer - Anf
Debug.Print Erg(0), Erg(1), Erg(2), Erg(3), Erg(4)
End With
End Sub

Auf einem Uralt-Laptop war das Ergebnis von Ego nach 96 Sekunden errechnet, eine äußere Schleife dauerte 133 Sekunden. Da aktuelle PC's mindesten 4 mal schneller (eher 10x) sind, ist der Code nicht nur einfacher strukturiert, sondern auch in der Laufzeit wettbewerbsfähg.

mfg

[Ego]

Hallo Fennek,

entweder ich habe deine Beschreibung nicht verstanden oder dein Uralt-Laptop ist um Längen besser als mein Rechner.

Auf meinem Rechner läuft dein Programm 10 Minuten und 29 Sekunden.

Auf jeden Fall scheinst du meine letzten Beiträge nicht gelesen zu haben. Wenn ich in deinem Programm die Zeile

       If Not .exists(Res(I)) Then Y = .Item(Res(I))

durch

       Y = .Item(Res(I))

ersetze, benötigt es 6 Minuten und 28 Sekunden, da bei jedem nicht existierenden Eintrag nicht mehr 2Mal geprüft wird ob er vorhanden ist.

Ich nehme an, dass das unnötige kopieren der Spalten in ein neues Array (Res) auch noch einige Sekunden kostet.

Meine letzte Version benötigt, da ich nur noch das optimale Ergebnis in das Blatt schreibe,  6 Minuten und 20 Sekunden.

[Fennek]

Hallo,

das ist der letzte Code, der deine Anregungen aufgreift. Er ist um 1/3 schneller.

Code:

Sub T4()
'90 Sek für 1 Schliefe j0
Anf = Timer
Dim Erg(4)

F0 = Sheets("Ori").Cells(1).CurrentRegion
With CreateObject("scripting.dictionary")
For j0 = 1 To UBound(F0, 2) - 3
For j1 = j0 + 1 To UBound(F0, 2) - 2
For j2 = j1 + 1 To UBound(F0, 2) - 1
For j3 = j2 + 1 To UBound(F0, 2)
   For i = 1 To UBound(F0)
       y = .Item(F0(i, j3))
       y = .Item(F0(i, j2))
       y = .Item(F0(i, j1))
       y = .Item(F0(i, j0))
   Next

   If .Count > Erg(0) Then
       Erg(0) = .Count
       Erg(1) = j0
       Erg(2) = j1
       Erg(3) = j2
       Erg(4) = j3
       Debug.Print Timer - Anf, .Count, j0, j1, j2, j3
   End If
.RemoveAll
Next j3
Next j2
Next j1
Debug.Print Timer - Anf
Next j0
Debug.Print Timer - Anf
Debug.Print Erg(0), Erg(1), Erg(2), Erg(3), Erg(4)
End With
End Sub

mfg