Hallo zusammen,

ich hoffe sehr auf eure Hilfe.  Mit dem unten genannten Code löse ich folgende Aufgabestellung: Vergleiche Spalte B (Inventarnummern) aus Tabellenblatt "Neudaten" und "Altdaten".  Gibt es die Inventarnummer nicht in "Altdaten" dann kopiere den ganzen Datensatz bestehend aus Spalten A bis K aus "Neudaten" in das Blatt "Altdaten" und füge in Spalte L den Wert "Neu" ein. Gibt es die Inventarnummer bereits im Blatt "Altdaten", dann kopiere den Datensatz nicht aus "Neudaten".Und  genau hier gibt es jetzt die Änderung:

Gib es die Inventarnummer im Blatt "Altdaten" bereits, dann kopiere die Spalten  A bis K aus "Neudaten" in den alten  Datensatz im Blatt "Altdaten". Das ist wichtig, denn ist dürfen keine Duplikate vorhanden sein und die alten Datensatze in "Altdaten"  werden um die Spalte L -AC erweitert.

Wie kann der vorhandene Code dafür angepasst werden?:

Sub Vergleich()
 Dim zells As Range
 Dim x As Long
 Dim rng As Range
 Dim lastn As Long
 Dim lasta As Long
 Dim ws1 As Worksheet
 Dim ws2 As Worksheet
 Set ws1 = Worksheets("Neudaten")
 Set ws2 = Worksheets("Altdaten")
 lastn = ws1.Cells(1048576, 2).End(xlUp).Row
 lasta = ws2.Cells(1048576, 2).End(xlUp).Row
  With ws1.Range("B2:B" & lastn)
 .NumberFormat = General
 .Value = .Value
 Set objDic = CreateObject("Scripting.Dictionary")
 Dim v, e
 With ws2.Range("B2:B" & lasta)
     v = .Value
 End With
       
     For Each e In v
         If Not objDic.Exists(e) Then objDic.Add e, e
    Debug.Print e
       Next
 
 
 Set rng = ws1.Range("B2:B" & lastn)
 
     With ws2.Cells.Interior
         .Pattern = xlNone
         .TintAndShade = 0
         .PatternTintAndShade = 0
 End With
 
 ws2.Cells.Columns(30).Clear
 
 For Each zells In rng
 lasta2 = ws2.Cells(1048576, 2).End(xlUp).Row
   If Not objDic.Exists(zells.Value) Then
   ws1.Range("A" & zells.Row & ":" & "K" & zells.Row).Copy ws2.Range("A" & lasta2 + 1)
   ws2.Range("L" & lasta2 + 1) = "Neu"
   End If
        Next
 
 Set objDic = Nothing

 
 
  Set objDic2 = CreateObject("Scripting.Dictionary")
 Dim b, c
 With ws1.Range("B2:B" & lastn)
     b = .Value
 End With
       
     For Each c In b
         If Not objDic2.Exists(c) Then objDic2.Add c, c
    Debug.Print c
       Next
       
       
   Dim zells2 As Long
    lasta2 = ws2.Cells(1048576, 2).End(xlUp).Row
        For zells2 = 2 To lasta2
        If ws2.Cells(zells2, 2).Value = "" Then GoTo XXX
         If Not objDic2.Exists(ws2.Cells(zells2, 2).Value) Then
     ws2.Rows(zells2).Delete Shift:=xlUp
     
     zells2 = zells2 - 1
     End If
XXX:
    Next
 Set objDic2 = Nothing
 End With
  With Worksheets("Altdaten")
      .Columns("A:AC").Sort Key1:=.Range("J2"), Order1:=xlDescending, Header:=xlYes, OrderCustom:=1, _
         MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
   End With
 MsgBox "Vergleich beendet!"
 End Sub

Vielen Dank für eure Hilfe.