metin içinde benzer karakterleri bulma

[spacebar]

arkadaşlar merhaba,
değişik bir sorunum var. Yapılabileceğinden çok emin değilim. ancak bazen öyle şeyler yapıyorsunuz ki hayretler için de kalıyorum.excelde yapılamıyacak bir şey yok gibi geliyor. En azından fikrinizi almak isterim. Sorunum şu:
excelde bir karakter bile farklı olduğunda iki hücreyi ayrı algılaması.aslında aynı olan iki hücredeki veriyi, uyarması veya düzeltmesi.

xyz limited şirketi
xyz lımıted şirketi 2.ile arasındaki tek fark "ı" ve "i" karakterleri
abc a.ş.
abc a.ş. 2.ile arasındaki fark diğerinde iki boşluk olması
hasçelik a.ş.
has çelik a.ş. 2.ile arasındaki fark birleşik yazılmaması
aslında aynı olan bu kelimeler excelde bir doğrulama veya filtreleme yapıldığında farklı gibi algılanıyor. Bunu düzeltmek mümkün müdür. Fikirlerinizi almak isterim. Teşekkürler iyi çalışmalar…

 

[ugurcadir]

Sadece sorunun ı-i ve boşluk ise bir çözüm yolum var. ama bunun dışında medical-medikal gibi bir sorun varsa o konuda yardım edemem

 

[spacebar]

yanlış veri girişini önlemek için liste+veri doğrulama var. ama veri başkasından gelince bunu engelleyemiyoruz. çözümünüzü öğrenmek isterim. adnanaltun35@gmail.com adresine gönderebilirsiniz. değisik bir sorun sanırım. diğer üstadların da ilgisini çeker diye düşünüyorum

 

[ÖmerBey]

Merhaba,
Biraz kafa yorayım dedim ve şöyle bir şey çıktı ortaya...
A sütununa doğru isimleri B sütununa da hatalı yazılmış isimleri yazıp kodun çalışmasını deneyebilirsiniz.

Sub karşılaştır()
Set h1 = Range("AA65000")
Set h2 = Range("AB65000")
For i = 1 To Range("A65500").End(3).Row
    For j = 1 To Range("B65500").End(3).Row
        If Cells(i, 1) = Cells(j, 2) Or Cells(i, 1) = "" Or Cells(j, 2) = "" Then GoTo sonra
        d1 = Cells(i, 1)
        d2 = Cells(j, 2)
        bul = Array(" ", ".", "-")
        For a = 0 To UBound(bul)
            d1 = Replace(d1, bul(a), "")
            d2 = Replace(d2, bul(a), "")
        Next
        fark = 0
        If d1 = d2 Then
            eşleşme = MsgBox("Eşleşme bulundu." & Chr(10) & Cells(i, 1) & " ve " & Cells(j, 2) & Chr(10) & "Veriler değiştirilsin mi?", vbYesNo)
            If eşleşme = vbYes Then Cells(j, 2) = Cells(i, 1): GoTo sonra Else GoTo sonra
        ElseIf Len(d1) = Len(d2) Then
            For b = 1 To Len(d1)
                If Mid(d1, b, 1) <> Mid(d2, b, 1) Then fark = fark + 1
            Next
            If fark <= 3 Then
                eşleşme = MsgBox("Eşleşme bulundu." & Chr(10) & Cells(i, 1) & " ve " & Cells(j, 2) & Chr(10) & "Veriler değiştirilsin mi?", vbYesNo)
                If eşleşme = vbYes Then Cells(j, 2) = Cells(i, 1): GoTo sonra Else GoTo sonra
            End If
        ElseIf Abs(Len(d1) - Len(d2)) <= 3 Then
            If Len(d1) < Len(d2) Then
                küçük = d1
                büyük = d2
            Else
                küçük = d2
                büyük = d1
            End If
    
            If Abs(Len(d1) - Len(d2)) = 1 Then
                For x = 1 To Len(büyük)
                    h1.Value = küçük
                    h2.Value = büyük
                    h2.Characters(x, 1).Delete
                    If h1 = h2 Then
                        eşleşme = MsgBox("Eşleşme bulundu." & Chr(10) & Cells(i, 1) & " ve " & Cells(j, 2) & Chr(10) & "Veriler değiştirilsin mi?", vbYesNo)
                        If eşleşme = vbYes Then Cells(j, 2) = Cells(i, 1): GoTo sonra Else GoTo sonra
                    End If
                Next
            ElseIf Abs(Len(d1) - Len(d2)) = 2 Then
                For x = 1 To Len(büyük) - 1
                    For y = x + 1 To Len(büyük)
                        h1.Value = küçük
                        h2.Value = büyük
                        h2.Characters(y, 1).Delete
                        h2.Characters(x, 1).Delete
                        If h1 = h2 Then
                            eşleşme = MsgBox("Eşleşme bulundu." & Chr(10) & Cells(i, 1) & " ve " & Cells(j, 2) & Chr(10) & "Veriler değiştirilsin mi?", vbYesNo)
                            If eşleşme = vbYes Then Cells(j, 2) = Cells(i, 1): GoTo sonra Else GoTo sonra
                        End If
                    Next
                Next
            ElseIf Abs(Len(d1) - Len(d2)) = 3 Then
                 For x = 1 To Len(büyük) - 2
                    For y = x + 1 To Len(büyük) - 1
                        For Z = y + 1 To Len(büyük)
                            h1.Value = küçük
                            h2.Value = büyük
                            h2.Characters(Z, 1).Delete
                            h2.Characters(y, 1).Delete
                            h2.Characters(x, 1).Delete
                            If h1 = h2 Then
                                eşleşme = MsgBox("Eşleşme bulundu." & Chr(10) & Cells(i, 1) & " ve " & Cells(j, 2) & Chr(10) & "Veriler değiştirilsin mi?", vbYesNo)
                                If eşleşme = vbYes Then Cells(j, 2) = Cells(i, 1): GoTo sonra Else GoTo sonra
                            End If
                        Next
                    Next
                Next
            End If
        End If
sonra:
    Next
Next
h1.Value = ""
h2.Value = ""
End Sub

 

[Murat OSMA]

Alternatif olarak bu konuya da bakılabilir;

http://www.excel.web.tr/f48/kysmen-veya-tamamen-benzer-metinleri-bulma-hk-acil-t135398/sayfa6.html

 

[Tevfik_Kursun]

İlgileriniz için çok teşekkür ederim. Benim de işime yaradı.
Saygılarımla
Tevfik Kurşun

 

[spacebar]

yeni bir şey daha öğrendim. excelde yok yok. imkansız sadece biraz zaman alıyor. ilgilerinize teşekkür ederim. saygılarımla...