Üç Sayfadaki Verileri Karşılaştırmak

[iznik]

Üç sayfadan oluşan bir çalışma kitabım var. Birinci sayfadaki isimleri ikinci ve üçüncü sayfadaki isimler ile karşılaştırıp aynı olan isimleri yeni bir sayfaya aktarılmasını istiyorum. Şimdiden teşekkür ederim.

 

[Korhan Ayhan]

Eşleşme olduğunda hangi başlıklar 3, sayfaya aktarılacak?

 

[iznik]

Eşleşme olduğunda hangi başlıklar 3, sayfaya aktarılacak?

Cevabınız için teşekkür ederim. İsim ve Soyisim ler aktarılacak.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Satir As Long, Son As Long, Say As Long
    Dim Sayfa As Worksheet, Veri As Object
    Dim Dizi As Variant, X As Long
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Rapor").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Set S1 = Sheets("Anket")
    
    Son = S1.Cells(Rows.Count, 1).End(3).Row
    
    Set Veri = CreateObject("Scripting.Dictionary")
    
    Dizi = S1.Range("A2:A" & Son).Value
    
    With CreateObject("Scripting.Dictionary")
        For X = 1 To UBound(Dizi, 1)
            .Item(Dizi(X, 1)) = Dizi(X, 1)
        Next
        
        For Each Sayfa In ThisWorkbook.Worksheets
            If Sayfa.Name <> "Anket" And Sayfa.Name <> "Rapor" Then
                Son = Sayfa.Cells(Sayfa.Rows.Count, "Q").End(3).Row
                Dizi = Sayfa.Range("Q4:Q" & Son).Value
        
                For X = 1 To UBound(Dizi, 1)
                    If .Exists(Dizi(X, 1)) Then
                        If Not Veri.Exists(Dizi(X, 1)) Then
                            Say = Say + 1
                            Veri.Add Dizi(X, 1), Say
                        End If
                    End If
                Next
            End If
        Next
    End With
    
    If Say > 0 Then
        Sheets.Add , Sheets(Sheets.Count)
        Set S2 = ActiveSheet
        S2.Name = "Rapor"
        
        S2.Range("A1") = "EŞLEŞEN AD-SOYADLAR"
        S2.Range("A1").Font.Bold = True
        Satir = 2
        
        S2.Range("A2").Resize(Say) = Application.Transpose(Veri.Keys)
        S2.Range("A:A").EntireColumn.AutoFit
    End If
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

    If Say > 0 Then
        MsgBox "İşlemınız tamamlanmıştır." & vbCrLf & vbCrLf & Say & " adet eşleşen kayıt bulunmuştur.", vbInformation
    Else
        MsgBox "Eşleşen kayıt bulunamadı!", vbExclamation
    End If
End Sub