Veri kontrol

[polis-53]

Merhaba arkadaşlar ekte ki dosyada sayfa 1 ve Sayfa2 nin A sütunlarına veriler var Sayfa2 de sayfa1 in A sütunundaki 1586 ile 1100 yok Sayfa1 de ise sayfa2 nin A sütunundaki 1099 ile 1011 yok ben bunları sayfa3 e aktarmasını ve hangi sayfada olduğunu gösterhttp://s6.dosya.tc/server6/2cuxzw/VERI_KONTROL.xls.htmlmesini istiyorum Yardımcı olursanız sevinirim.

 

[Ziynettin]

Merhaba,

Dosyanız ekte...

Option Explicit

Sub Olmayanlar()
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
Dim a(), b(), c(), d As Object
Dim i As Long, Say As Long

Application.ScreenUpdating = False
  
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
Set S3 = Sheets("Sayfa3")

a = S2.Range("A2:A" & S2.Cells(Rows.Count, 1).End(3).Row)
b = S1.Range("A2:A" & S1.Cells(Rows.Count, 1).End(3).Row)
  
Set d = CreateObject("Scripting.Dictionary")
ReDim c(1 To UBound(a) + UBound(b), 1 To 3)
  
    For i = 1 To UBound(a)
        d(a(i, 1)) = 1
    Next i
  
    For i = 1 To UBound(b)
        If Not d.exists(b(i, 1)) Then
            Say = Say + 1
            c(Say, 1) = b(i, 1)
            c(Say, 2) = S1.Name
            c(Say, 3) = "Satır :  " & i + 1
        End If
    Next i

Set d = CreateObject("Scripting.Dictionary")
  
    For i = 2 To UBound(b)
        d(b(i, 1)) = 1
    Next i
    
    For i = 2 To UBound(a)
        If Not d.exists(a(i, 1)) Then
            Say = Say + 1
            c(Say, 1) = a(i, 1)
            c(Say, 2) = S2.Name
            c(Say, 3) = "Satır :  " & i + 1
        End If
    Next

If Say > 0 Then
    S3.Range("A2:C" & Rows.Count).ClearContents
    S3.[A2].Resize(Say, 3) = c
Else
    MsgBox "Yazdırılacak Veri Bulunamadı", vbExclamation
    Exit Sub
End If
Application.ScreenUpdating = True
MsgBox "İşlem Tamam.", vbInformation

Set d = Nothing: i = Empty: Say = Empty
End Sub

 

[polis-53]

çok teşekkür ederim kal sağlıcakla