Werte auf Übereinstimmung prüfen

[sunny01]

Hallo,

ich habe folgendes Problem. Ich versuche in einer Tabelle einige Spalten auf Übereinstimmungen zu überprüfen und anschließend (bei Übereinstimmung) Werte zu kopieren. Der Code, den ich verwende, benötigt bei den vorhandenen 4000 Einträgen jedoch viel zu lange. Beiliegend (als Excel File) und unten ist ein Beispiel mit dem verwendeten Code. In der beiliegenden Excel-Datei sind lediglich ein paar Einträge zum Testen des Codes beinhaltet. Damit wird - wie oben erwähnt - die Übereinstimmung von Einträgen in einer Tabelle überprüft und bei Übereinstimmung der Einträge werden gewisse Werte der jeweiligen Zeile in die jeweils andere Zeile kopiert. 

Wer könnte mir zu diesem Code eine Alternative weitergeben, der schneller ist und bei einigen Tausend Einträgen anwendbar wäre. Eventuell lässt sich auch der angegebene Code noch beschleunigen. 

Vielen Dank für Eure Mithilfe!

Code:

Sub Beispiel()

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With

Dim LoL_1 As Long
Dim LoL_2 As Long
Dim x1 As Long
Dim x2 As Long
Dim ws1 As Worksheet
Set ws1 = Worksheets("Tabelle1")
Dim ws2 As Worksheet
Set ws2 = Worksheets("Tabelle1")

    With Worksheets("Tabelle1")
        LoL_1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row
        LoL_2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
        For x1 = 1 To LoL_1
        For x2 = 1 To LoL_2
            If ws2.Range("E" & x2) = ws1.Range("J" & x1) And ws2.Range("A" & x2) = ws1.Range("A" & x1) And ws2.Range("C" & x2) = ws1.Range("H" & x1) And ws2.Range("I" & x2) <> "" Then    
                ws1.Range("K" & x1) = ws2.Range("A" & x2)
                ws1.Range("L" & x1) = ws2.Range("C" & x2)
            End If
        Next
        Next
    End With

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
  
End Sub

[Ego]

Hallo s...,

bei 4.000 Zeilen machst du 16.000.000 Vergleiche mit 7 Werten. Du greifst also 112.000.000 mal einzeln auf Daten des Arbeitsblattes zu.

In der Anlage habe ich einmal in zwei Schriiten Verbesserungen eingebaut.

1. Nutzen von Arrays und einmaliges Lesen und Ausgeben der Daten aus und in das Arbeitsblatt. (Sub BeispielArr)
Die 16.000.000 Vergleiche Werden im Programmspeicher durgeführt.

2. Zusätzlich Einlesen der Vergleichsdaten in ein Dictionary (schnell zu durchsuchende Datenspeicherung) (Sub BeispielDict)
Anstelle von 16.000.000 Vergleichen werden 4.000 Werte ins Dictionary geschrieben und 4.000 mal jeweils zweimal im Dictionary gesucht.

Insgesamt sollte das bei 4.000 Zeilen eine zeitliche Verbesserungen um einen Faktor weit über 1.000 ergeben.

[sunny01]

Hallo Helmut,

vielen Dank für Deine überzeugenden Lösungsvarianten mit Geschwindigkeitsvergleich! Ich habe schon vermutet, dass mein Code in der Formulierung unnötig viel Zeit verbraucht und für meine Anwendung ungeeignet ist. Ich hätte noch folgende Fragen zu Deinen Varianten:

1. Nutzen von Arrays: 
Liste = ws2.Range("A1").Resize(LoL_2, 9).Value
Weshalb wird hier auf Spalte I verwiesen? (ich nehme an zur Abklärung, dass nur die Zellen bearbeitet werden, welche befüllt sind)

2. Einlesen der Vergleichsdaten in ein Dictionary:
Liste2 = ws2.Range("A1").Resize(LoL_2, 9).Value
Liste1 = ws1.Range("A1").Resize(LoL_1, 10).Value
Weshalb wird hier auf Spalte I und Spalte J verwiesen?

Eine weitere Frage wäre, was sich ändert, wenn die Daten auf zwei Worksheets verteilt werden. Müßte ich da lediglich die Angaben der Variablen ws1 und ws2 anpassen und die jeweiligen Spaltenangaben anpassen?

[Ego]

Hallo s...,

zu 1. und 2.
Ich übernehme nur die Daten in den Speicher, die für das Makro benötigt werden.

zu 3.
Ja, das ist richtig. Nach deinem Makro habe ich damit gerechnet. Ansonsten könnte man nur ein Array nutzen.

Achtung!
Beim Rückschreiben des Arrays "Ausgabe" werden dort die Werte eingetragen. Zwar bleiben diese in nicht bearbeiteten Zellen erhalten, aber falls dort Formeln vorhanden waren, werden sie durch die Ergebniswerte ersetzt. Aus diesem Grund (und weil es ein wenig schneller ist) habe ich die Ausgabe im 2. Beispiel auf zwei Spalten begrenzt.

[sunny01]

Hallo Helmut,

eine Frage habe ich noch zum Makro BeispielDict:

was muss ich am Code ändern, wenn ich eine Zahl mit zwei Nachkommastellen (z.B. 43,67) anstatt von Text ausgeben möchte (muss dann einfach die String Variable von "Text" geändert werden)!?

[Ego]

Hallo s...,

anstelle von

Ausgabe(x1, 2) = Text(1)

dann

If IsNumeric(Text(1)) Then
   Ausgabe(x1, 2) = CDbl(Text(1))
Else
    Ausgabe(x1, 2) = Text(1)
End If