İki ayrı sayfadaki verileri karşılaştırma, farklılıkları yeni sayfaya aktarma

[hsayar]

Herkese selamlar,
1) 2020 ve 2021, farklar adlı üç ayrı sayfamız var.
2) her üç sayfada da ID, AD, ÜRETİM YERİ, ÜRETİM TARİHİ adlı sütun başlıkları var. FARKLAR sayfasında ek olarak SONUÇ sütunu var
3) verilerimiz 2. satırlardan başlıyor. 10bin ve üzeri satıra sahip.
öyle bir makro yapalım ki
2021 yılı ID sütunu ile 2020 yılı ID sütunları karşılaştırılsın.
hem 2020 yılı hem 2021 yılı ID lerde eşleşenler kalsın,
Ancak;
2020 yılı ID de olup 2021 yılı ID de olmayanlar farklar sayfasına sıra ile ID, AD, ÜRETİM YERİ, ÜRETİM TARİHİ, bilgilerine ek olarak ESKİMİŞ,
2021 yılı ID de olup 2020 yılı ID de olmayanlar farklar sayfasına sıra ile ID, AD, ÜRETİM YERİ, ÜRETİM TARİHİ, bilgilerine ek olarak yeni,
bilgisi ile raporlansın.
ne yapılabilir?
Saygılarımla,

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki kodu deneyiniz.
Bu türden sorularda örnek dosya hazırlayarak sormanız çok daha hızlı ve doğru yanıt almanızı sağlar.
Aşağıdaki kod işinizi görmezse örnek dosya hazırlayınız.

Sub Test()
    Dim syf_1 As Worksheet
    Dim syf_2 As Worksheet
    Dim syfFark As Worksheet
    Dim Bak As Long
    Dim Bul As Range
    Dim Durum(1) As String
    Dim Fark As Variant
    Dim Say As Long
   
    Durum(0) = "ESKİMİŞ"
    Durum(1) = "YENİ"
    Set syfFark = Worksheets("Farklar")
    For Each Fark In Durum
        If Fark = "ESKİMİŞ" Then
            Set syf_1 = Worksheets("2020")
            Set syf_2 = Worksheets("2021")
        ElseIf Fark = "YENİ" Then
            Set syf_1 = Worksheets("2021")
            Set syf_2 = Worksheets("2020")
        End If
        For Bak = 2 To syf_1.Cells(Rows.Count, "A").End(xlUp).Row
            Set Bul = syf_2.Range("A:A").Find(what:=syf_1.Cells(Bak, "A").Value, lookat:=xlWhole)
            If Bul Is Nothing Then
                Say = syfFark.Cells(Rows.Count, "A").End(xlUp).Row + 1
                syfFark.Range("A" & Say & ":D" & Say).Value = syf_1.Range("A" & Bak & ":D" & Bak).Value
                syfFark.Range("E" & Say).Value = Fark
            End If
        Next
    Next
    MsgBox "Tamamlandı.",vbInformation
End Sub

 

[veyselemre]

Sub test()
    Dim son1&, son2&, sonF&, rng As Range
    son2 = Sheets("2021").Cells(Rows.Count, 1).End(3).Row
    Sheets("Farklar").Cells.ClearContents
    
    With Sheets("2020")
        son1 = .Cells(Rows.Count, 1).End(3).Row
        .Range("E2:E" & son1).Formula = "=COUNTIF('2021'!A$2:A$" & son2 & ",'2020'!A2)"
        .Range("A1:E" & son1).AutoFilter Field:=5, Criteria1:="0"
        .Range("A1").CurrentRegion.Copy Sheets("Farklar").Range("A1")
        If Evaluate("=SUBTOTAL(102,A2:A" & son1 & ")") > 0 Then
            .Range("2:" & son1).Delete
        End If
        .Range("A1:E" & son1).AutoFilter
        .Range("E2:E" & son1).ClearContents
    End With
    
    sonF = Sheets("Farklar").Cells(Rows.Count, 1).End(3).Row

    With Sheets("2021")
        .Range("E2:E" & son2).Formula = "=COUNTIF('2020'!A$2:A$" & son1 & ",'2021'!A2)"
        .Range("A1:E" & son2).AutoFilter Field:=5, Criteria1:="0"
        If Evaluate("=SUBTOTAL(102,A2:A" & son2 & ")") > 0 Then
            .Range("A1").CurrentRegion.Offset(1).Copy Sheets("Farklar").Range("A" & sonF + 1)
            .Range("2:" & son2).Delete
        End If
        .Range("A1:E" & son2).AutoFilter
        .Range("E2:E" & son2).ClearContents
    End With
    
    With Sheets("Farklar")
        If sonF > 1 Then .Range("E2:E" & sonF).Value = "ESKİMİŞ"
        If .Cells(Rows.Count, 1).End(3).Row > sonF Then .Range("E" & sonF + 1 & ":E" & .Cells(Rows.Count, 1).End(3).Row).Value = "YENİ"
    End With
End Sub