Macro Vergleich 2er Tabellen Ergebnis in Tabelle_3

Question

Hallo, ich bin Anfänger in Sachen Macro-Programmierung und habe folgendes Problem, evtl. kann mir jemand helfen:

Vergleich.xls
Tabelle 1 enthält Daten 1 Basiswerte
A B C
Nr Name 1 Name 2
12345 Max Meyer
23456 Niko Schmitt
34567 Mary Zweier
45678 Susi Groß
80123 Werner Kurtz
76554 Fritz Lang
89765 Geli Schwarz

Tabelle 2 enthält Daten 2 Fehlerwerte
A B C
Nr KZ 1 KZ 2
54321 Kein Land xabcfg
45678 Kein Ort ghnvj
76543 Kein Land klmmno
43210 Kein Land olimhg

Tabelle 3 enthält Ergebnis Basis u Fehlerwerte
A B C D E
Nr Name 1 Name 2 KZ 1 KZ 2
45678 Susi Groß Kein Land klmmno

In Tabelle 3 sollen nur die Zeilen eingefügt werden, die in Tabelle 1 und Tabelle 2 enthalten sind.

Answer 1

Hi,

Das liesse sich erledigen wie folgt:

Sub alpha()

With Application
.EnableEvents = False 'Events abschalten
.ScreenUpdating = False 'Bildschirmaktualisierung abschalten
.Calculation = xlCalculationManual 'Berechnungsmodus auf Manuell
End With

'wenn Fehler gehe zum Ende
On Error GoTo ErrEnde

'Variablendeklaration
Dim shQuel As Worksheet, shVerg As Worksheet, shZiel As Worksheet
Dim lngQLR As Long, lngZLR As Long, lngQR As Long, lngVR As Long


'Tabellen benennen
With ThisWorkbook
Set shQuel = Sheets("Tabelle1")
Set shVerg = Sheets("Tabelle2")
Set shZiel = Sheets("Tabelle3")
End With

'ZielBereich A2 bis ELetzte in Ziel löschen
shZiel.Range("A2:E" & Rows.Count).Clear

'letzte Reihe in Quelle
lngQLR = shQuel.Cells(Rows.Count, 1).End(xlUp).Row

'Quellreihen durlaufen
'Wenn Nummer in Vergleichstabelle vorhanden
'Reihennummer raussuchen
'entspr. Werte aus Quelle und Vergleich nach Ziel kopieren
For lngQR = 2 To lngQLR
If WorksheetFunction.CountIf(shVerg.Range("A:A"), shQuel.Cells(lngQR, 1).Value) Then
lngVR = Application.WorksheetFunction.Match(shQuel.Cells(lngQR, 1).Value, shVerg.Range("A:A"), 0)
lngZLR = shZiel.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
shQuel.Range(shQuel.Cells(lngQR, 1), shQuel.Cells(lngQR, 3)).Copy
shZiel.Cells(lngZLR, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
shVerg.Range(shVerg.Cells(lngVR, 2), shVerg.Cells(lngVR, 3)).Copy
shZiel.Cells(lngZLR, 4).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
Next

ErrEnde:
'Zwischenablage löschen
Application.CutCopyMode = False
'Verweise aufheben
Set shQuel = Nothing
Set shVerg = Nothing
Set shZiel = Nothing

With Application
.EnableEvents = True 'Events einschalten
.ScreenUpdating = True 'Bildschirmaktualisierung einschalten
.Calculation = xlCalculationAutomatic 'Berechnungsmodus auf auto
.Calculate 'Mappen neu rechnen
End With

End Sub

Kopiere diesen Code in ein Standardmodul und starte ihn über eine Tastenkombination oder Befehlsschaltfläche.

bye
malSchauen

Answer 2

Hallo malSchauen,
Super schnell und alles hat bestens gefunzt,
Vielen Dank, alpha_golf