VBA: Abgleich zweier Excel Tabellen

Herzliches Hallo an alle :)

Ich habe ein Problem, und hoffe, dass ihr mir weiter helfen könnt.

Ich habe eine Excel Datei A, wo in der Spalte N Zahlenwerte stehen, in einer andere Excel Datei B sind in der Spalte C ebenso Zahlenwerte. Nun soll abgeglichen werden ob z.B. der Wert in N2 in der Spalte C in dem anderen Arbeitsblatt vorkommen, wenn das der Fall ist, soll in dieser Zeile in der Spalte R "Online" stehen, wenn nicht dann "STP".
Und so soll die ganze Tabelle abgearbeitet werden. Die Anzahl der Zeilen kann in beiden Dokumenten variieren - können aber auch mal ca. 100.000 Zeilen sein.

Ich hoffe ich hab mich verständlich ausgedrückt.

Über eure Hilfe würde ich mich sehr freuen - trotz Suchfunktion komm ich hier leider nicht weiter.

LG,
Andy

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Dateien_vergleichern() Dim rFind As Range, lzA As Long, lzB As Long Dim DatA As Worksheet, DatB As Worksheet Set DatA = Workbooks("Test Juli.xls").Worksheets("Tabelle1") Set DatB = Workbooks("Test Juli.xls").Worksheets("Tabelle2") '** Lastzell aus Spalte N+C ermitteln lzA = DatA.Cells(Rows.count, 14).End(xlUp).Row lzB = DatB.Cells(Rows.count, 3).End(xlUp).Row DatB.Range("R2:R" & lzB) = "STP" 'Alle Zeilen aus DateiA Spalte N in DateiB Spalte C suchen For Each AC In DatA.Range("N2:N" & lzA) If AC.Value = Empty Then GoTo nx Set rFind = DatB.Columns(3).Find(What:=AC, After:=[c1], LookIn:=xlFormulas, LookAt:= _ xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False) If Not rFind Is Nothing Then DatB.Cells(rFind.Row, "R") = "Online" nx: End If Next AC End Sub

Moin,

guter Code, Piet!
Damit habe ich meine anfangliche Faulheit überwunden.

Bei 100.000 Zeilen sollte man auf die übliche Leistungsbremse achten:
_ Events und Updating ausschalten (eigentlich immer)
_ einmalig in einem Array und die einzelnen aus dem Array lesen (erst bei grossen Anzahl an Zellen relevant)
_ in einem Dictionary packen, um über den Schlüssel direkt das Element finden ( Cells.Find in Kombi mit der Menge ist wahrscheinlich eine Plage)

Nicht getestet, ich hoffe, ich habe keine Patzer gemacht.

Sub Dateien_vergleichen()
Dim Arr
Dim Dic
Dim Z

'Bremse auschalten
    Application.ScreenUpdating = False
    Application.EnableEvents = False
'Eingangsdaten in einem Array
    With Workbooks("Test Juli.xls").Worksheets("Tabelle1")
        Arr = Range(.Range("C2"), .Cells(Rows.Count, "C").End(xlUp)).Value
    End With
'Array in einem Dictionary
    Set Dic = CreateObject("Scripting.Dictionary")
    For Z = 1 To UBound(Arr, 1) ' Z ist hier ein Zähler
        Dic(Arr(Z, 1)) = 1
    Next
'Zweite Tabelle befüllen
    With Workbooks("Test Juli.xls").Worksheets("Tabelle2")
        For Each Z In Range(.Range("N2"), .Cells(Rows.Count, "N").End(xlUp)) 'Z ist hier eine Zelle
            Z.Offset(1, 0) = IIf(Dic.Exists(Z.Value), "Online", "STP")
        Next
    End With
'weil nicht umsonst da, wieder einschalten
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

VG
Yal

Sub Dateien_vergleichen() Dim Arr Dim Dic Dim Z Dim Arr2 'Eingangsdaten in einem Array With Workbooks("Test Juli.xls").Worksheets("Tabelle1") Arr = Range(.Range("C2"), .Cells(Rows.Count, "C").End(xlUp)).Value End With 'Array in einem Dictionary Set Dic = CreateObject("Scripting.Dictionary") For Z = 1 To UBound(Arr, 1) ' Z ist hier ein Zähler Dic(Arr(Z, 1)) = 1 Next With Workbooks("Test Juli.xls").Worksheets("Tabelle2") 'Vergleichswerte in Array + ZielWert-Array Arr = Range(.Range("N2"), .Cells(Rows.Count, "N").End(xlUp)).Value ReDim Arr2(1 To UBound(Arr, 1)) 'Vergleichen und einstellen For Z = 1 To UBound(Arr, 1) Arr2(Z) = IIf(Dic.Exists(Arr(Z)), "Online", "STP") Next 'an der Ziel-Stelle ablegen .Range("R2").Resize(UBound(Arr2), 1) = Application.Transpose(Arr2) End With End Sub

with .Range(.Range("N2"), .Cells(Rows.Count, "N").End(xlUp)) Arr = .Value 'Vergleichen und einstellen For Z = 1 To UBound(Arr, 1) Arr(Z, 1) = IIf(Dic.Exists(Arr(Z, 1)), "Online", "STP") Next 'an der Ziel-Stelle ablegen .Offset(0, 4).value = Arr end with

Beliebteste Forumthreads (12 Monate)

VBA: Abgleich zweier Excel Tabellen

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

195 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA: Abgleich zweier Excel Tabellen

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

195 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread