Tabellen zusammenführen

Hallo liebe Forumsteilnehmer und Experten,
für meine heutige Problemstellung suche ich eine VBA-Lösung. Es werden 2 Tabellen ("Tabelle1" und "Tabelle2") in einer ("Tabelle1") zusammengeführt und alle Abweichungen mit "Treffer" in Spalte G gekennzeichnet.
Meine Errungenschaften sehen erst einmal so aus:


Sub test()
Dim arr1(), arr2(), lRow1 As Long, lRow2 As Long
Dim WS1 As Worksheet, WS2 As Worksheet
Set WS1 = ThisWorkbook.Worksheets("Tabelle1")
Set WS2 = ThisWorkbook.Worksheets("Tabelle2")
lRow1 = WS1.Cells(Rows.Count, 1).End(xlUp).Row
lRow2 = WS2.Cells(Rows.Count, 1).End(xlUp).Row
ReDim arr1(lRow1 - 1, 9) As Variant
ReDim arr2(lRow2 - 1, 1) As Variant
arr1 = WS1.Range("A1:I" & lRow1)
arr2 = WS2.Range("A1:f" & lRow2)
For i = 2 To UBound(arr1)
For j = 2 To UBound(arr2)
If arr1(i, 1) = arr2(j, 1) Then
GoTo weiter
End If
Next j
arr1(i, 7) = "Treffer"
weiter:
Next i
For j = 2 To UBound(arr2)
For i = 2 To UBound(arr1)
If arr2(j, 1) = arr1(i, 1) Then
GoTo weiter2
End If
Next i
a = a + 1
ReDim arr1(lRow - 1 + a, 9)
For b = 1 To 6
arr1(lRow - 1 + a, b) = arr2(j, b)
Next b
arr1(lRow - 1 + a, 7) = "Treffer2"
weiter2:
Next j
WS1.Range("A1:I" & lRow1 + a).Value = arr1()
End Sub

Im Tabellenblatt "Ziel" kann man sehen, wie "Tabelle1" aussehen soll, wenn denn das Makro machte, was ich mir von ihm wünschte. Könnt Ihr mir bitte sagen, woran es da noch hapert? Vielen lieben Dank schon jetzt für Eure Unterstützung!
https://www.herber.de/bbs/user/128620.xlsx
lGrüße
Toni

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public Sub Zusammen() Dim loLetzte As Long, loLetzteZiel As Long Application.ScreenUpdating = False With Worksheets("Tabelle1") loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row .Range(.Cells(1, 1), .Cells(loLetzte, 9)).Copy With Worksheets("Ziel") loLetzteZiel = .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Row If .Cells(1, 1) = "" Then loLetzteZiel = 1 .Cells(loLetzteZiel, 1).PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False End With End With With Worksheets("Tabelle2") loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row .Range(.Cells(2, 1), .Cells(loLetzte, 6)).Copy With Worksheets("Ziel") loLetzteZiel = .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Row .Cells(loLetzteZiel, 1).PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False loLetzteZiel = .Cells(.Rows.Count, 1).End(xlUp).Row .Range("$A$1:$I$" & loLetzteZiel).RemoveDuplicates Columns:=1, Header:=xlYes loLetzteZiel = .Cells(.Rows.Count, 1).End(xlUp).Row .Range(.Cells(2, 7), .Cells(loLetzteZiel, 7)).FormulaLocal = _ "=WENN(ZÄHLENWENNS(Tabelle1!A:A;Ziel!A2;Tabelle2!A:A;Ziel!A2)=1;"""";" _ & "WENN(ISTZAHL(A2*1);""Treffer2"";""Treffer""))" .Range(.Cells(2, 7), .Cells(loLetzteZiel, 7)).Value = _ .Range(.Cells(2, 7), .Cells(loLetzteZiel, 7)).Value End With End With End Sub

Sub test() Sheets("Tabelle1").UsedRange.Copy Sheets("Ziel").Cells(1, 1) Sheets("Tabelle2").UsedRange.Offset(1, 0).Copy Sheets("Ziel").Cells(1, 1).End(xlDown).Offset(1, _ 0) With Sheets("Ziel").UsedRange .RemoveDuplicates 1, xlYes With .Columns(7) .FormulaR1C1 = "=CHOOSE(ISNUMBER(MATCH(RC[-6],Tabelle1!C[-6],0))*1+ISNUMBER(MATCH(RC[-6] _ ,Tabelle2!C[-6],0))*2+1,"""",""Treffer1"",""Treffer2"","""")" .Formula = .Value End With End With End Sub

Option Explicit Sub test2() Dim lRow1 As Long, lRow2 As Long Dim WS1 As Worksheet, WS2 As Worksheet Dim RAFound1 As Range Dim I As Long Set WS1 = ThisWorkbook.Worksheets("Tabelle1") Set WS2 = ThisWorkbook.Worksheets("Tabelle2") lRow1 = IIf(IsEmpty(WS1.Cells(Rows.Count, 1)), WS1.Cells(Rows.Count, 1).End(xlUp).Row, WS1. _ Rows.Count) lRow2 = IIf(IsEmpty(WS2.Cells(Rows.Count, 1)), WS2.Cells(Rows.Count, 1).End(xlUp).Row, WS2. _ Rows.Count) ReDim arr1(lRow1 - 1, 9) As Variant ReDim arr2(lRow2 - 1, 1) As Variant For I = 2 To lRow1 Set RAFound1 = WS2.Columns(1).Find(WS1.Cells(I, 1), WS1.Range("A" & Rows.Count), _ xlFormulas, _ xlWhole, , xlNext) If RAFound1 Is Nothing Then WS1.Cells(I, 7) = "Treffer 1" End If Next I For I = 2 To lRow2 Set RAFound1 = WS1.Columns(1).Find(WS2.Cells(I, 1), WS1.Range("A" & Rows.Count), _ xlFormulas, _ xlWhole, , xlNext) If RAFound1 Is Nothing Then WS2.Rows(I).Copy WS1.Rows(lRow1 + 1) WS1.Cells(lRow1 + 1, 7) = "Treffer 2" lRow1 = lRow1 + 1 End If Next I End Sub

Also Hajo, ich bin platt! Ich habe nichts gefunden, aber der Reihe nach:
1. diese Konstruktion:

    lRow1 = IIf(IsEmpty(WS1.Cells(Rows.Count, 1)), WS1.Cells(Rows.Count, 1).End(xlUp).Row, WS1.  _
_
Rows.Count)

du denkst sogar an die letzte Zelle ;), kannt ich so auch noch nicht, merke ich mir!
2. dies hier:

        Set RAFound1 = WS2.Columns(1).Find(WS1.Cells(I, 1), WS1.Range("A" & Rows.Count), _
xlFormulas, _
xlWhole, , xlNext)

habe ich wegen des zweiten WS1 vermutet, dass da ein WS2 kommen müsste. Da aber letzte Zelle immer leer sein wird, lass ich das. Auch xlFormulas hat er akzeptiert, hatte auch hier zunächst anders xlValues vermutet. Top, läuft durch
3. dies:


WS2.Rows(I).Copy WS1.Rows(lRow1 + 1)

werde ich explizit auf die ersten 6 Spalten reduzieren ... ist aber absolut unerheblich.
So: und nun frage ich mich: der Hajo baut doch eigentlich immer was ein, was habe ich übersehen ^^
Also: ich unterstell jetzt einfach, dass das ne Unterstellung ist und bedanke mich vielmals, dass Du Dich der Sache noch angenommen hast!
lG Toni!

Sub test() Dim dic As Object Dim sh Dim arr Dim z As Long, x As Long Dim K Set dic = CreateObject("Scripting.dictionary") For Each sh In Array("Tabelle1", "Tabelle2") arr = Sheets(sh).UsedRange.Columns(1).Value x = x + 1 For z = 2 To UBound(arr, 1) dic(arr(z, 1)) = dic(arr(z, 1)) + x Next Next For Each K In dic.Keys Select Case dic(K) Case 1: dic(K) = "Tabelle1" Case 2: dic(K) = "Tabelle2" Case 3: dic(K) = "" Case Else: dic(K) = "?" End Select Next Sheets("Tabelle2").UsedRange.Offset(1, 0).Copy With Sheets("Tabelle1") .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll .UsedRange.RemoveDuplicates 1, xlYes With .Cells(1, 1).CurrentRegion arr = .Columns(1).Value arr(1, 1).Cells(1, 7).Value For z = 2 To UBound(arr, 1) arr(z, 1) = dic(arr(z, 1)) Next .Columns(7).Value = arr End With End With End Sub

Beliebteste Forumthreads (12 Monate)

21 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

21
Beiträge zum Forumthread

Beiträge zu diesem Forumthread