Kısmen ya da Tamamen Benzer Verileri Tespit Etme

Yazım yanlışlarından ötürü birbirinden farklı olan hücrelerdeki verilerden, kısmen ya da tamamen benzer olan hücreleri tespit etmek için kullanılabilir..

Özellikle şu zamanlarda [b]E-fatura[/b] müşterilerini maliye sitesinden alıp, kendi carileri ile karşılaştırmak isteyen [b]Excel[/b] kullanıcılarının oldukça işine yarayacağı bir çalışma.. 

Faydalı olması dileğiyle..  

■ [b]Module içerisine;[/b]

Option Compare Text
DefObj A-B, R-S
DefInt C, I
Sub Hücreleri_Karşılaştır()
    Dim Evn As Range, Mrt As Range
    Set Reg = CreateObject("VBScript.RegExp")
    Set Rky = CreateObject("VBScript.RegExp")
    Columns("C:E").Clear
    Rky.Global = True: Rky.IgnoreCase = True
    Reg.Global = True: Reg.IgnoreCase = True
    Rky.Pattern = "[0-9a-z\s\ç\Ç\ö\Ö\ş\Ş\ı\İ\ğ\Ğ\ü\Ü]{3,}"
    Reg.Pattern = "[0-9a-z\s\ç\Ç\ö\Ö\ş\Ş\ı\İ\ğ\Ğ\ü\Ü]{3,}"
    For i = 1 To Range("A65536").End(3).Row
        Set say = Reg.Execute(Cells(i, 1))
        Set soy = Rky.Execute(Cells(i, 2))
        If say.Count > 0 Then Cells(i, 3) = Reg.Execute(Cells(i, 1)).Item(0)
        If soy.Count > 0 Then Cells(i, 4) = Rky.Execute(Cells(i, 2)).Item(0)
        For Each ara In say
            For Each bul In soy
                For C = 1 To bul.Length
                    If Mid(ara, 1, C) = Mid(bul, 1, C) Then
                        Set Evn = Columns(3).Find(ara, , , 2)
                        If Not Evn Is Nothing Then
                            dali = Evn.Address
                            Do
                            Set Evn = Columns(3).FindNext(Evn)
                            Evn.Offset(0, 2).Value = "DOĞRU"
                            Evn.Offset(0, 2).Font.ColorIndex = 45
                            Loop While Not Evn Is Nothing And dali <> Evn.Address
                        End If
                    ElseIf Right(Mid(ara, 1, C), 3) = Right(Mid(bul, 1, C), 3) Then
                        Set Mrt = Columns(3).Find(ara, , , 2)
                        If Not Mrt Is Nothing Then
                            dali = Mrt.Address
                            Do
                            Set Mrt = Columns(3).FindNext(Mrt)
                            Mrt.Offset(0, 2).Value = "DOĞRU"
                            Mrt.Offset(0, 2).Font.ColorIndex = 45
                            Loop While Not Mrt Is Nothing And dali <> Mrt.Address
                        End If
                    Else
                    End If
                Next C
            Next bul
        Next ara
        If Cells(i, 5) = "" Then Cells(i, 5) = "YANLIŞ": Cells(i, 5).Font.ColorIndex = 3
    Next i
    Columns.AutoFit
    Set Reg = Nothing: Set Rky = Nothing: Set Evn = Nothing: Set Mrt = Nothing: C = Empty
    Set ara = Nothing: Set bul = Nothing: Set say = Nothing: Set soy = Nothing: i = Empty:
End Sub

Örnek Excel Sayfa görüntüsü; 
[img] [/img]

Not: Kodlar A sütunu ile B sütununu karşılaştırır. Sizin karşılaştırmak istediğiniz sütunlar farklı ise koddaki ilgili yerleri değiştirmeniz gerek. Verileriniz A ve B sütunlarında olursa sorunsuz bir şekilde karşılaştırıp sonuç alabilirsiniz.

Hoşça kalın !