VBA - Suche von Zellinhalt und einfügen von Zeilen

Hallo zusammen,
ich lese nun schon seit einiger Zeit hier im Forum mit und bin von eurer Hilfsbereitschaft echt begeistert. Ich beschäftige mich noch nicht so lange mit VBA und bin nun auf ein Problem gestoßen bei dem ich ohne Hilfe leider nicht weiterkomme. Erfolglos gesucht habe ich bereits.
Ich habe zwei Tabellen. Die Nummer aus Tabelle 1 soll in Tabelle 2 gesucht werden. Da die Nummer in Tabelle 2 öfters vorkommt sollen alle Treffer untereinander in Tabelle 3 ausgegeben und der Inhalt von Tabelle 1 und Tabelle 2 konsolidiert werden (wie 1a, 2a) und dann nach der nächsten Nummer gesucht werden. Wenn die Nummer nicht in Tabelle 2 vorkommt, soll nur der Inhalt von Tabelle 1 ausgegeben werden. (wie 3a)
Kommt in Tabelle 2 eine Nummer vor, die nicht in Tabelle 1 vorkommt, dann soll diese in Tabelle 4 wiedergegeben werden. Tabelle 1-4 ist jeweils 1 Worksheet. In der Realität bestehen die Tabellen aus mehreren Spalten als hier angegeben.
Nachdem ich übers Wochenende endlos rumprobiert und gesucht habe bin ich mittlerweile echt ratlos. Eigentlich kann das ja nicht so schwer sein. Könnt ihr mir weiterhelfen?
Tabelle1:
Nr: Name:
1a abc
1b abc
2a def
3a ghi
3b ghi
Tabelle 2:
Nr: Wert:
1a 111
1a 222
1b 333
2a 444
2a 555
3c 777
Tabelle3:
Nr: Name: Wert:
1a abc 111
1a abc 222
1b abc 333
2a def 444
2a def 555
3a ghi
3b ghi
Tabelle4:
Nr: Name: Wert:
3c ghi 777

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub TabellenKonsolidieren() Dim ArrayTab1, ArrayTab2 As Variant Dim ArrayConsolidated() Dim i, x As Integer Dim Tab1, Tab2, Tab3, Tab4 As Worksheet Set Tab1 = ThisWorkbook.Sheets(1) Set Tab2 = ThisWorkbook.Sheets(2) Set Tab3 = ThisWorkbook.Sheets(3) Set Tab4 = ThisWorkbook.Sheets(4) ArrayTab1 = Tab1.Range("A2:B" & Tab1.Cells(Rows.Count, 2).End(xlUp).Row) ArrayTab2 = Tab2.Range("A2:B" & Tab2.Cells(Rows.Count, 2).End(xlUp).Row) For i = LBound(ArrayTab1, 1) To UBound(ArrayTab1, 1) For x = LBound(ArrayTab2, 1) To UBound(ArrayTab2, 1) If ArrayTab1(i, 1) = ArrayTab2(x, 1) Then Sheets(3).Cells(x + 1, 1) = ArrayTab1(i, 1) Sheets(3).Cells(x + 1, 2) = ArrayTab1(i, 2) Sheets(3).Cells(x + 1, 3) = ArrayTab2(x, 2) End If Next x Next i 'Fehlende Nr in Tab2 in Tab3 eintragen Dim LastRow As Integer Dim NrFinden, SucheTab1, SucheTab2 As Range Dim r As Range Set SucheTab2 = Tab2.Range("A1", Tab2.Range("A1").End(xlDown)) Set SucheTab1 = Tab1.Range("A1", Tab1.Range("A1").End(xlDown)) For Each r In Tab1.Range("A2", Tab1.Range("A1").End(xlDown)) Set NrFinden = SucheTab2.Find(r) LastRow = Tab3.Cells(Rows.Count, 1).End(xlUp).Row + 1 If NrFinden Is Nothing Then Tab3.Cells(LastRow, 1) = r Tab3.Cells(LastRow, 2) = r.Offset(0, 1) End If Next r 'Fehlende Nr in Tab1 in Tab4 eintragen For Each r In Tab2.Range("A2", Tab2.Range("A1").End(xlDown)) Set NrFinden = SucheTab1.Find(r) LastRow = Tab4.Cells(Rows.Count, 1).End(xlUp).Row + 1 If NrFinden Is Nothing Then Tab4.Cells(LastRow, 1) = r Tab4.Cells(LastRow, 3) = r.Offset(0, 1) End If Next r End Sub

Hallo
hier ein Code mit 3 Schleifen. Er müsste funktionieren
mfg Piet

Option Explicit
Sub Daten_konsolidieren()
Dim Tb1 As Worksheet
Dim Tb2 As Worksheet
Dim Tb4 As Worksheet
Dim t As Long, n As Long
Dim lz1 As Long, lz2 As Long
Dim AC As Range, AJ As Range
Set Tb1 = Worksheets("Tabelle1")
Set Tb2 = Worksheets("Tabelle2")
Set Tb4 = Worksheets("Tabelle4")
lz1 = Tb1.Cells(Rows.Count, 1).End(xlUp).Row
lz2 = Tb2.Cells(Rows.Count, 1).End(xlUp).Row
With Worksheets("Tabelle3")
'LatZell in Tabelle 1+2 suchen
lz1 = Tb1.Cells(Rows.Count, 1).End(xlUp).Row
lz2 = Tb2.Cells(Rows.Count, 1).End(xlUp).Row
'Tabelle 3+4 Bereich löschen
n = .Cells(Rows.Count, 1).End(xlUp).Row + 1
t = Tb4.Cells(Rows.Count, 1).End(xlUp).Row + 1
.Range("A2:C" & n).Clear
Tb4.Range("A2:C" & t).Clear
t = 2  '1.Zeile in Tab.3 setzen
'1.Schleife für Werte in Tabelle1 + 2 suchen
For Each AC In Tb1.Range("A2:A" & lz1)
For Each AJ In Tb2.Range("A2:A" & lz2)
If AC.Value = AJ.Value Then
.Cells(t, 1) = AC.Value
.Cells(t, 2) = AC.Cells(1, 2)
.Cells(t, 3) = AJ.Cells(1, 2)
t = t + 1: n = n + 1
End If
Next AJ
Next AC
'2.Schleife in Tabelle1 Name ohne Werte suchen
For Each AC In Tb1.Range("A2:A" & lz1)
n = 0  'Werte Zaehler löschen
For Each AJ In Tb2.Range("A2:A" & lz2)
If AC.Value = AJ.Value Then _
n = n + 1: Exit For
Next AJ
'Name ohne Wert notieren
If n = 0 Then
.Cells(t, 1) = AC.Value
.Cells(t, 2) = AC.Cells(1, 2)
t = t + 1
End If
Next AC
t = 2  '1.Zeile in Tab.4 setzen
'3.Schleife in Tabelle2 Wert ohne Name suchen
For Each AC In Tb2.Range("A2:A" & lz2)
n = 0  'Werte Zaehler löschen
For Each AJ In Tb1.Range("A2:A" & lz1)
If AC.Value = AJ.Value Then _
n = n + 1: Exit For
Next AJ
'Wert ohn Name notieren
If n = 0 Then
Tb4.Cells(t, 1) = AC.Value
Tb4.Cells(t, 3) = AC.Cells(1, 2)
t = t + 1
End If
Next AC
End With
MsgBox "Ende"
End Sub

Beliebteste Forumthreads (12 Monate)

VBA - Suche von Zellinhalt und einfügen von Zeilen

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

331 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA - Suche von Zellinhalt und einfügen von Zeilen

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

331 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread