Datenabgleich über zwei Blätter
01.10.2019 14:48:09
Georg
https://www.herber.de/bbs/user/132312.xlsx
Das Ganze übersteigt glaube ich etwas meine Kenntnisse, der Code steht unten als Versuch.
Es soll von Blatt Skills fehlende Zeilen anhand der P-Nummer in Spalte A ins Blatt Costs kopiert werden.
Der Code läuft, er kopiert aber immer nur den letzten fehlenden, im Beispiel müssten 2 Datensätze kopiert werden.
Und zusätzlich möchte ich die Tabelle im Blatt Costs fortsetzen mit den fehlenden Zeilen. Der Code fügt aber diese eine Zeile unterhalb der Tabelle ein.
Dass die Spalten nciht übereinstimmen, ist zweitrangig, korrigiere ich an anderer Stelle.
Vielen Dank für eure Tipps!! G
Sub FehlendeDS()
Dim LoI As Long
Dim lgLastCost As Long
Dim lgLastSkill As Long
Dim RaFound As Range '
Dim wsCosts As Worksheet
Dim wsSkills As Worksheet
Application.ScreenUpdating = False '
Set wsCosts = Worksheets(1) ' setzen Tabelle1
Set wsSkills = Worksheets(2) ' setzen Tabelle2
With wsCosts ' letzte Zeile _
Spalte D P-Nummern in Kosten ermitteln
lgLastCost = IIf(IsEmpty(.Cells(Rows.Count, 4)), _
.Cells(Rows.Count, 4).End(xlUp).Row, .Rows.Count)
End With
With wsSkills ' letzte Zeile _
Spalte B P-Nummern in Skills ermitteln
lgLastSkill = IIf(IsEmpty(.Cells(Rows.Count, 1)), _
.Cells(Rows.Count, 1).End(xlUp).Row, .Rows.Count)
End With
For LoI = 2 To lgLastSkill ' Schleife über Kopie
If wsSkills.Cells(LoI, 1) "" Then
Set RaFound = wsCosts.Range("D2:J" & lgLastCost).Find(wsSkills.Cells(LoI, 1), _
wsCosts.Range("D" & lgLastCost), , xlWhole, , xlNext)
If RaFound Is Nothing Then ' Begriff gefunden
wsSkills.Rows(LoI).Copy ' gefundene Zeile kopieren
With Worksheets(1)
.Rows(lgLastCost + 1).PasteSpecial Paste:=xlValues
' Formate übertragen
.Rows(lgLastCost + 1).PasteSpecial Paste:=xlFormats
End With
End If
End If
Next LoI
Application.CutCopyMode = False
Application.ScreenUpdating = True ' Bildschirmaktualisierung ein
End Sub