Clever-Excel-Forum - 4 Spalten mit geringster Schnittmenge an Werten auswählen

Seiten: 1 2

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.

@ Ego

gute Arbeit!

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

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.

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

Seiten: 1 2