Tabellenvergleich_komplex

Hallo zusammen,
ich hoffe ihr könnt mir weiterhelfen.
Onkel Google war leider keine Hilfe :(
Momentan verzweifele ich an einem Werksvergleich, der die Unterschiede in ein neues 3. Tabellenblatt schreibt.
Als Datenbasis habe ich 2 Tabellen, die Spaltenüberschriften/Aufbau ist vollkommen identisch.
Als eindeutig zuordnenbares Kriterium ist die Artikelnummer vorhanden.
Die Sortierung ist in beiden Tabellen vollkommen willkürlich (kein Abgleich nach TabelleA1=Tabelle2A1 möglich).
Bis auf die Artikelnummer kann jedes Feld auch ein Leerfeld sein.
In beiden Tabellen gibt es eine Spalte (Werk/ in den Beispieldateien Spalte D), die sich auf jedenfall unterscheidet, diese muss aber mitkopiert werden.
(Ich kann diese aber in jede beliebige Spalte verschieben.)
Jetzt bräuchte ich einen Abgleich der beiden Tabellen nach der Artikelnummer.
Wenn in beiden Tabellen die gleiche Artikelnummmer vorkommt, müssen die weiteren Zellen in der gleichen Zeile auch abgeglichen werden.
Bei Unterschieden, egal in welcher Tabelle müssen beide Zeilen,komplett, in eine neues 3. Blatt kopiert werden.
Falls ein Artikel nur in einer Tabelle vorhanden ist, muss dieser auch in das neue 3. Blatt kopiert werden, in beiden Tabellen möglich.
Ich habe eine kleine Beispieldatei angehangen, die Originale haben ca. 10.000 Zeilen und Spalten bis BK.
Wenn es als anspornt hilft, lasse ich auch gerne einen kleinen Betrag per Paypal springen, ich bin wirklich verzweifelt ;)
LG
Jens
https://www.herber.de/bbs/user/120077.xlsx

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub F_en() T1 = Sheets(1).Cells(1).CurrentRegion T2 = Sheets(2).Cells(1).CurrentRegion lr3 = Sheets(3).Cells(Rows.Count, 1).End(xlUp).Row + 1 ls = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column For i = 2 To UBound(T1) ii = Application.Match(T1(i, 1), Sheets(2).Columns(1), 0) If Not IsError(ii) Then Abw = 0 For j = 2 To UBound(T1, 2) If T1(i, j) T2(ii, j) Then Abw = Abw + 1 Next j If Abw > 1 Then With Sheets(1) .Range(.Cells(i, 1), .Cells(i, ls)).Copy Sheets(3).Cells(lr3, 1) lr3 = lr3 + 1 End With With Sheets(2) .Range(.Cells(ii, 1), .Cells(ii, ls)).Copy Sheets(3).Cells(lr3, 1) lr3 = lr3 + 1 End With End If T2(ii, 1) = "a" Else 'Unikate in Mat1 Sheets(3).Cells(lr3, 1) = T1(i, 1) lr3 = lr3 + 1 End If Next i 'Prüfung auf Unikate in Mat2 For ii = 2 To UBound(T2) If T2(ii, 1) "a" Then For j = 1 To ls Sheets(3).Cells(lr3, j) = T2(ii, j) Next j lr3 = lr3 + 1 End If Next ii End Sub

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread