Çoklu sütun koşuluna göre uyuşmayan verileri listelemek

[Believing]

Sayın Uzman arkadaşlar,

Ekteki çalışma kitaplarında farklı sütunlarda bulunan adı, soyadı ve oda numarası sütunlarını karşılaştırmak, uyuşmayanları renklendirmek ve her iki çalışma kitabına göre uyuşmayanları listelemek istiyorum.
Konu ile ilgili örnek çalışmaları incelememe rağmen henüz müspet bir sonuca ulaşamadım.
Bu koşullara göre uyuşmayan verileri tespit ve listelemek için nasıl bir yöntem kullanmalıyım?
Benim için çok değerli olan yardımlarınızı rica ediyorum.

Saygılarımla,

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki kodları bir modüle kopyalayın ve çalıştırın.


Karşılaştırılacak her iki dosya da açık olmalı.
Eğer gerçek dosyalarınızın ve sayfalarınızın isimleri farklıysa ilgili yerleri düzeltirsiniz.

Sub Karsilastir()
    Dim syf1 As Worksheet, syf2 As Worksheet
    Dim Bak1 As Long, Bak2 As Long
    Dim Bulundu As Boolean
    
    Set syf1 = Workbooks("Dosya-1.xls").Worksheets("Sheet1")
    Set syf2 = Workbooks("Dosya-2.xls").Worksheets("Sheet1")
    
    For Bak1 = 2 To syf1.Cells(Rows.Count, "A").End(xlUp).Row
        For Bak2 = 2 To syf2.Cells(Rows.Count, "C").End(xlUp).Row
            If syf2.Cells(Bak2, "D") = syf1.Cells(Bak1, "A") And _
                syf2.Cells(Bak2, "C") = syf1.Cells(Bak1, "H") And _
                syf2.Cells(Bak2, "P") = syf1.Cells(Bak1, "J") Then
                Bulundu = True
                Exit For
            Else
                Bulundu = False
            End If
        Next
        If Bulundu Then
            syf1.Range("A" & Bak1 & ":L" & Bak1).Interior.Pattern = xlNone
        Else
            With syf1.Range("A" & Bak1 & ":L" & Bak1).Interior
                .TintAndShade = 0.599993896298105
                .ThemeColor = xlThemeColorAccent4
            End With
        End If
    Next
    
    For Bak2 = 2 To syf2.Cells(Rows.Count, "C").End(xlUp).Row
        For Bak1 = 2 To syf1.Cells(Rows.Count, "A").End(xlUp).Row
            If syf2.Cells(Bak2, "D") = syf1.Cells(Bak1, "A") And _
                syf2.Cells(Bak2, "C") = syf1.Cells(Bak1, "H") And _
                syf2.Cells(Bak2, "P") = syf1.Cells(Bak1, "J") Then
                Bulundu = True
                Exit For
            Else
                Bulundu = False
            End If
        Next
        If Bulundu Then
            syf2.Range("A" & Bak2 & ":Q" & Bak2).Interior.Pattern = xlNone
        Else
            With syf1.Range("A" & Bak1 & ":L" & Bak1).Interior
            End With
            With syf2.Range("A" & Bak2 & ":Q" & Bak2).Interior
                .TintAndShade = 0.599993896298105
                .ThemeColor = xlThemeColorAccent4
            End With
        End If
    Next
End Sub

 

[Believing]

Sayın Muzaffer bey,

Konuya gösterdiğiniz ilgi ve yardım için size çok teşekkür ederim. Kodlarınız mevcut çalışma üzerinde çok güzel çalışmıştır.
Affınıza sığınarak, sizlerden bir isteğim daha olacak. Web uygulaması sık sık güncelleme yaptığından bizde sistemde küçük bir güncellemeye gittik.
Bu sebep ile asıl çalışma ile sütun sayıları, yerleri ve formatları birebir aynı olan bir örnek çalışma daha hazırladım.
Yapılması gerekenler örnek çalışmadaki sarı renkli alanlardır.
Web Uygulaması sayfasında problem varsa "K" ve "L" sütunlarına problemin detayı yazılarak satır renklendirilmelidir.
System sayfasında problem varsa "S" ve "T" sütunlarına problemin detayı yazılarak satır renklendirilmelidir.
RAPOR sayfasında olması gereken bilgiler örnek olması için manuel oluşturulmuştur.
Bu koşulları sağlayacak kodlamayı yaparsanız çok makbule geçecektir.

Saygılarımla,

 

[Muzaffer Ali]

Aşağıdaki kodları bir modüle kopyalayıp deneyin.

    Dim syf1 As Worksheet, syf2 As Worksheet, syfRpr As Worksheet
    Dim Bak1 As Long, Bak2 As Long
    Dim Bulundu As Boolean
    Dim Sira As Long

Sub Karsilastir()
    Set syf1 = ThisWorkbook.Worksheets("WEB_UYGULAMASI")
    Set syf2 = ThisWorkbook.Worksheets("SYSTEM")
    Set syfRpr = ThisWorkbook.Worksheets("RAPOR")
    HerIkiSayfadaUyusmayanlar
    WebdeOlupSystemdeOlmayanlar
    SystemdeOlupWebdeOlmayanlar
    Set syf1 = Nothing
    Set syf2 = Nothing
    Set syfRpr = Nothing
End Sub

Sub SystemdeOlupWebdeOlmayanlar()
    Sira = syfRpr.Cells(Rows.Count, "K").End(xlUp).Row + 1
    syfRpr.Range("K3:N" & Sira).Clear
    
     For Bak2 = 2 To syf1.Cells(Rows.Count, "A").End(xlUp).Row
        For Bak1 = 2 To syf2.Cells(Rows.Count, "A").End(xlUp).Row
            If syf2.Cells(Bak2, "A") = syf1.Cells(Bak1, "G") And _
                syf2.Cells(Bak2, "P") = syf1.Cells(Bak1, "J") Then
                Bulundu = True
                Exit For
            Else
                Bulundu = False
            End If
        Next
        If Bulundu = False Then
            Sira = syfRpr.Cells(Rows.Count, "K").End(xlUp).Row + 1
            syfRpr.Cells(Sira, "K") = syf2.Cells(Bak2, "D")
            syfRpr.Cells(Sira, "L") = syf2.Cells(Bak2, "C")
            syfRpr.Cells(Sira, "M") = syf2.Cells(Bak2, "A")
            syfRpr.Cells(Sira, "N") = syf2.Cells(Bak2, "P")
        End If
    Next
End Sub

Sub WebdeOlupSystemdeOlmayanlar()
    Sira = syfRpr.Cells(Rows.Count, "F").End(xlUp).Row + 1
    syfRpr.Range("F3:I" & Sira).Clear
    
     For Bak1 = 2 To syf1.Cells(Rows.Count, "A").End(xlUp).Row
        For Bak2 = 2 To syf2.Cells(Rows.Count, "A").End(xlUp).Row
            If syf2.Cells(Bak2, "A") = syf1.Cells(Bak1, "G") And _
                syf2.Cells(Bak2, "P") = syf1.Cells(Bak1, "J") Then
                Bulundu = True
                Exit For
            Else
                Bulundu = False
            End If
        Next
        If Bulundu = False Then
            Sira = syfRpr.Cells(Rows.Count, "F").End(xlUp).Row + 1
            syfRpr.Cells(Sira, "F") = syf1.Cells(Bak1, "A")
            syfRpr.Cells(Sira, "G") = syf1.Cells(Bak1, "H")
            syfRpr.Cells(Sira, "H") = syf1.Cells(Bak1, "G")
            syfRpr.Cells(Sira, "I") = syf1.Cells(Bak1, "J")
        End If
    Next
End Sub

Sub HerIkiSayfadaUyusmayanlar()

    Sira = syfRpr.Cells(Rows.Count, "A").End(xlUp).Row + 1
    syfRpr.Range("A3:D" & Sira).Clear
    
    For Bak1 = 2 To syf1.Cells(Rows.Count, "A").End(xlUp).Row
        For Bak2 = 2 To syf2.Cells(Rows.Count, "A").End(xlUp).Row
            If syf2.Cells(Bak2, "D") = syf1.Cells(Bak1, "A") And _
                syf2.Cells(Bak2, "C") = syf1.Cells(Bak1, "H") And _
                syf2.Cells(Bak2, "P") = syf1.Cells(Bak1, "J") Then
                Bulundu = True
                Exit For
            Else
                Bulundu = False
            End If
        Next
        If Bulundu = False Then
            Sira = syfRpr.Cells(Rows.Count, "A").End(xlUp).Row + 1
            syfRpr.Cells(Sira, "A") = syf1.Cells(Bak1, "A")
            syfRpr.Cells(Sira, "B") = syf1.Cells(Bak1, "H")
            syfRpr.Cells(Sira, "C") = syf1.Cells(Bak1, "G")
            syfRpr.Cells(Sira, "D") = syf1.Cells(Bak1, "J")
            
        End If
    Next
    
    For Bak2 = 2 To syf2.Cells(Rows.Count, "A").End(xlUp).Row
        For Bak1 = 2 To syf1.Cells(Rows.Count, "A").End(xlUp).Row
            If syf2.Cells(Bak2, "D") = syf1.Cells(Bak1, "A") And _
                syf2.Cells(Bak2, "C") = syf1.Cells(Bak1, "H") And _
                syf2.Cells(Bak2, "P") = syf1.Cells(Bak1, "J") Then
                Bulundu = True
                Exit For
            Else
                Bulundu = False
            End If
        Next
        If Bulundu = False Then
            Sira = syfRpr.Cells(Rows.Count, "A").End(xlUp).Row + 1
            syfRpr.Cells(Sira, "A") = syf2.Cells(Bak2, "D")
            syfRpr.Cells(Sira, "B") = syf2.Cells(Bak2, "C")
            syfRpr.Cells(Sira, "C") = syf2.Cells(Bak2, "A")
            syfRpr.Cells(Sira, "D") = syf2.Cells(Bak2, "P")
        End If
    Next
End Sub