Metindeki en yakın(birbirine en fazla uyum sağlayan) veriyi bulma Makrosu

[akmlyx]

Değerli Üstatlar Merhaba,
Kurumlarda Taşınır işlemleri yapılması gerekiyor. Bu taşınıra kaydedilecek o kadar uzun liste oluyor ki listede bir hatalı giriş yaptığın zaman tüm kalemleri tek tek kontrol edilmesi gerekiyor. Bu kontrol işleminin makro ile yapılması için yardımcı olabilir misiniz?
Ek'teki Excel'de görüleceği üzere, yazılacak makro, sayfa1'deki G Sütununda yazan verileri, sayfa2'deki B sütunundaki verilerle tek tek kıyaslama yaparak en yakın(birbirine en fazla uyum sağlayan) veriyi bulup, verinin aynı satırına ait T sütunundaki ilgili hücresine sayfa2'deki en fazla uyum sağlayan veriyi yazacak.
Yardımlarınız için şimdiden çok teşekkür ederim.

 

[AdemCan]

Merhaba örnek olarak kod paylaşayım ancak G sütununda yazım yanlışı olan veriler var, bunları kontrol etmeniz gerekecek.
Örneğin
1- Bazı ürün isimlerinde yazım yanlışı var. Barbunya, B arbunya, Elma, Alma; Havuç, Havuc; Makarna, Makarnalar gibi yazılmış vb.

Eğer ürün isimlerinde düzenleme yapabiliyorsanız tek tip yazmanızda fayda var.
Örnek olarak ürün isimlerini yazarken kelimeleri alt tire ile birleştirebilirsiniz. Kırmızı_Mercimek gibi.

Bunu önermemdeki neden, paylaştığım kodlar parantez içindeki ilk kelimeyi alıyor ve Sayfa2 içinde arıyor.
Bu işlem bazı ürünlere hatalı karşılık getiriyor.

Örnek olarak
G sütununda Kabuksuz Yemişler (Kuru Uzüm .Markasız Kuru Üzüm) olan kayıt için makro Kuru kelimesini alıyor ve arama işlemi yapıyor. Sayfa2 içinde Kuru kelimesi geçen ilk bulduğu kaydı alıyor. Sonuç olarak ilk değer Karışık Kuru Yemiş olduğu için hatalı sonuç getirmiş oluyor.

Ancak belirttiğim gibi ürün isimlerini düzenleme imkanınız varsa arama sonucu doğru kayıtlar gelir.

Sub test()
On Error Resume Next

son = Sayfa1.Cells(Rows.Count, "G").End(3).Row
Sayfa1.Range("T3:T" & son).Clear

For x = 3 To son
    dizi = Split(Sayfa1.Cells(x, "G"), " ")
    
    For i = LBound(dizi) To UBound(dizi)
    kelime = dizi(i)
        If WorksheetFunction.IsErr(WorksheetFunction.Find("(", kelime)) = True Then
        
        Else
            kelime = WorksheetFunction.Substitute(kelime, "(", "")
                    
            If WorksheetFunction.CountIf(Sayfa2.Range("B2:B75"), "*" & kelime & "*") > 0 Then
                Sayfa1.Cells(x, "T") = Sayfa2.Range("B2:B75").Find(kelime).Value
            End If
            GoTo atla
        End If
    Next
atla:
Next
End Sub

 

[akmlyx]

Faye_Efsane hocam elinize sağlık, küçük birkaç hata olsa da makro çalışıyor. Teşekkür ederim.

 

[AdemCan]

Rica ederim, ürün isimleri tek tip olursa, o hatalar da gitmiş olur.