Soru Sütun karşılaştırma

[tukayf]

A sütununda 20bin satıra yakın veri var. Ve bu verilerin hepsi adres, bazı satırlar isim de içeriyor.
Günlük olarak 50-200 civarında adres bulmaya çalışıyorum. Adreslerin bir standardı yok. Birebir hiç bir zaman eşleşmiyor.
A sütunu sabit adreslerimiz.
Yeni gelen adresleri B sütununa, İsimleri ise C sütununa işlesek. B ve C sütununda bulunan değerleri A sütununda aratıp B ve C de bulunan verilere en yakın verileri renklendirme yapabilir mi.
Ya da ayırt etmeye yarayacak farklı bir çözüm var mıdır.

 

[tukayf]

Sn. turist cok tesekkur ederim. Ancak tek tek aramadan ziyade bir seferde b ve c sutunlarina yazdigim tum degerlerin aranmasini saglayacak bir cozum olabilir mi acaba? Cunku bu sekilde gelen yeni veriye gore gunde en az 100 kez tek tek arama yapmak zorunda kalacgim.

LG-H815 cihazımdan Tapatalk kullanılarak gönderildi

 

[turist]

Hücrelere yazarak arayacağınızın Adres Listenizde bulunamama ihtimali yüksek.
Verilen cevaptaki dosyada , sistemi "Google" araması gibi düşünürseniz;
Aradığınız herhangibir metin şekline göre birden fazla sonuç alabilirsiniz.
Ve listeden istediğiniz "DOĞRU" adresi seçme imkanınız olur.

Ancak; istediğiniz mantıkta, cevap verebilecek değerli Forum üyelerimiz konuya çözüm bulabilirler.
İyi çalışmalar.

 

[tukayf]

Açıklamalar için çok teşekkürler hocam. Başka bir çözüm gelmezse sizin çalışmanızı kullanacağım tekrardan teşekkürler.

 

[ÖmerBey]

Merhaba,
Verilerinizin bir standartı olmadığı için isteğinizin tam olarak yapılması oldukça güç gözüküyor, arada kaçan veri muhakkak olacaktır.
Örnek dosyanız için sizin isteğinizden biraz farklı bir mantık kurarak aşağıdaki kodu yazdım. Kod B sütunundaki adresleri kelime kelime ayırıp A sütununda arıyor ve en çok eşleşme sağladığı değeri D sütununa yazıyor. Eğer sizin için yeterli sonuçları verirse daha müsait bir zamanda üzerinde çalışmaya devam edebiliriz.
İyi çalışmalar...

Sub kod()
son = Cells(Rows.Count, "A").End(3).Row
Range("Z:Z").ClearContents
For a = 1 To Cells(Rows.Count, "B").End(3).Row
    dz = Range("Z1:Z" & son)
    veri = Split(Cells(a, "B").Text, " ")
    For b = 1 To son
        For Each v In veri
            If InStr(1, Cells(b, "A"), v) > 0 Then say = say + 1
        Next
        dz(b, 1) = say
        say = 0
    Next
    mak = WorksheetFunction.Match(WorksheetFunction.Max(dz), dz, 0)
    Cells(a, "D") = Cells(mak, "A")
Next
End Sub

 

[tukayf]

İlginiz için teşekkürler hocam detaylı incelemeden sonra sonucu yazacağım.

 

[tukayf]

İstenilen sonuca yakın olmuş hocam. Mümkünse en yakın değerlerin tümünü listeleyebilir mi? Eğer ki yapılabiliyorsa A sütununda köprü bulunan adresler için d ye köprüsüyle birlikte listeleyebilir mi?

 

[Ömer BARAN]

Merhaba.

Bir kod da ben oluşturmuştum. Deneyiniz.
Sayfaya 2 adet düğme ekleyin, bunlardan biriyle ARAMA, diğeriyle TEMİZLE makrosunu ilişkilendirin.
Arama alanındaki NO/CAD/MAH/SOK kısaltmaları ile ":" ve ". " yoksayılarak işlem yapılır.
Kod renklendirme yapmaktadır, renklendirme yerine listeleme de yapılabilir elbette.

Sub ARAMA()
Columns("D:E").Insert: son = Cells(Rows.Count, 1).End(3).Row
bson = Cells(Rows.Count, 2).End(3).Row : cson = Cells(Rows.Count, 3).End(3).Row
sonn = WorksheetFunction.Max(bson, cson): Columns("A:A").Interior.Color = xlNone
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual

For Each brn In Range("B1:C" & sonn)
    If brn <> "" Then
        kelime = WorksheetFunction.Trim(Replace(Replace(Replace(Replace(Replace( _
                Replace(Replace(Replace(Replace(Replace(UCase(brn), "MAH.", ""), _
                "MAH ", ""), "NO:", ""), "NO ", ""), "CAD ", ""), "SOK ", ""), "SOK.", " "), _
                "CAD.", " "), ":", " "), ".", " "))
        adet = Len(kelime) - Len(Replace(kelime, " ", ""))
        For k = 0 To adet
            klm = Split(kelime, " ")(k)
            For hrf = 1 To Len(klm)
                uz = Len(klm)
                If hrf = 1 Then hk1 = "": hk2 = Mid(klm, hrf + 1, uz)
                If hrf > 1 Then hk1 = Mid(klm, 1, hrf - 1): hk2 = Mid(klm, hrf + 1, uz)
                For asat = 1 To son
                    If Len(Cells(asat, 1)) - Len(Replace(Cells(asat, 1), hk1, "")) > 0 Or _
                       Len(Cells(asat, 1)) - Len(Replace(Cells(asat, 1), hk2, "")) > 0 Then
                        Cells(asat, brn.Column + 2) = Cells(asat, brn.Column + 2) + 1
                    End If
                Next
            Next
        Next
        mak = WorksheetFunction.Max(Range(Cells(1, brn.Column + 2), Cells(son, brn.Column + 2)))
        bulsat = WorksheetFunction.Match(mak, Range(Cells(1, brn.Column + 2), Cells(son, brn.Column + 2)), 0)
        Cells(bulsat, 1).Interior.ColorIndex = 43
        Columns("D:E").Delete Shift:=xlToLeft
    End If
Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub

Sub TEMIZLE()
    Columns("A:A").Interior.Color = xlNone
End Sub

 

[tukayf]

Değerli hocalarım yanıtlar için çok teşekkürler. 2 kodu da aynı anda kullanacağım. Yarın gerçek verilerle denemeleri yaptıktan sonra daha detaylı yazarım.

 

[Ömer BARAN]

Verdiğim kod, yok sayıldığını belirttiğim kısaltma ve noktalama işaretlerini ayıkladıktan sonra,
B ve C sütunundaki herbir kelimenin ilk harfinden son harfine kadar tek tek harf eksilterek
(bir anlamda kelimelerdeki TEK harf hatalarını, TEK harf eksikliklerini de kontrol etmiş oluyor)
arama yapar ve en çok eşleşmenin olduğu satırı tespit edip renklendirir.
Umarım işinize yarar.

 

[tukayf]

Kodlar çok işime yaradı hocam zihninize sağlık. Normalde kullandığımız işlem ctrl+f idi. Ama bu kodlarla işlem çok hızlandı tekrardan çok teşekkürler.

 

[tukayf]

Sn. Ömerbey

Sub kod()
son = Cells(Rows.Count, "A").End(3).Row
Range("Z:Z").ClearContents
For a = 1 To Cells(Rows.Count, "B").End(3).Row
    dz = Range("Z1:Z" & son)
    veri = Split(Cells(a, "B").Text, " ")
    For b = 1 To son
        For Each v In veri
            If InStr(1, Cells(b, "A"), v) > 0 Then say = say + 1
        Next
        dz(b, 1) = say
        say = 0
    Next
    mak = WorksheetFunction.Match(WorksheetFunction.Max(dz), dz, 0)
    Cells(a, "D") = Cells(mak, "A")
Next
End Sub

bu kodları 2 farklı dosya için kullanıyorum. Dosyanın birinde A sütununda köprü şeklinde gelen veriler var. Listelerken A dan aldığı veriyi köprü olarak listeleyebilir mi acaba?

 

[ÖmerBey]

Şu şekilde dener misiniz?

Sub kod()
son = Cells(Rows.Count, "A").End(3).Row
Range("Z:Z").ClearContents
For a = 1 To Cells(Rows.Count, "B").End(3).Row
    dz = Range("Z1:Z" & son)
    veri = Split(Cells(a, "B").Text, " ")
    For b = 1 To son
        For Each v In veri
            If InStr(1, Cells(b, "A"), v) > 0 Then say = say + 1
        Next
        dz(b, 1) = say
        say = 0
    Next
    mak = WorksheetFunction.Match(WorksheetFunction.Max(dz), dz, 0)
    Cells(a, "D") = Cells(mak, "A")
    If Cells(mak, "A").Hyperlinks.Count > 0 Then
        Cells(a, "D").Hyperlinks.Delete
        Cells(a, "D").Hyperlinks.Add Cells(a, "D"), Cells(mak, "A").Hyperlinks(1).Address
    End If
Next
End Sub

 

[tukayf]

Sn. Ömerbey çok teşekkürler. Bu haliyle dosya tamam oldu.