Bire bir aynı kelimeyi bulan macro hakkında

[search77]

Arkadaşlar merhaba,
Aşağıdaki macro E hücresinde bulunan kelimeleri gidiyor B hücresinde arıyor bulduğu hücreyi sarı renge boyuyor.
Fakat bu macro içeren kelimeyi de yakalayıp hücreyi sarıya boyuyor, benim istediğim ise bire bir aynı kelime varsa o şekilde hücreyi sarıya boyaması.
Örneğin benim E hücresindeki kelimem "zar" o gidiyor B hücresindeki zarar, zarlar, zarın, zarlandı .... vb gibi kelimeleri görüp hücreyi sarıya boyuyor ben bunu istemiyorum, sadece B hücresinde zar kelimesi geçiyorsa bire bir eşleştiği için bu tür durumlarda hücreyi sarıya boyasın.
Yardımcı olabileceklere şimdiden saygılar ve teşekkürler.


Sub askm()
Dim ara As Range
Dim ilkadres As String
Dim son1 As Long, son2 As Long
son1 = Range("B" & Rows.Count).End(3).Row
son2 = Range("E" & Rows.Count).End(3).Row

With Range("B1:B" & son1)
For i = 2 To son2
Set ara = .Find(Cells(i, "E"), LookIn:=xlValues)
If Not ara Is Nothing Then
ilkadres = ara.Address
Do
Cells(ara.Row, 2).Interior.Color = vbYellow
Set ara = .FindNext(ara)
Loop While Not ara Is Nothing And ara.Address <> ilkadres
End If
Next i
End With
MsgBox "İşlem tamam", vbInformation, Application.UserName
End Sub

 

[Ömer]

Merhaba,

.Find(Cells(i, "E"), LookIn:=xlValues)

yerine aşağıdaki gibi kullanın.

.Find(Cells(i, "E"), , xlValues, xlWhole)

.

 

[search77]

Ömer bey öncelikle çok teşekkür ederim, fakat bu şekilde hücreler bire bir ise yakalıyor, örneğin B hücresinde "geldim" kelimesi var E hücresinde "Dün İstanbuldan geldim" ibaresi var bunu yakalayamıyor, ben E hücresinde bu kelime bire bir geçiyor ise yakalasın istiyorum.

Bu şekilde hangi komutu kullanmamız gerekir acaba?

 

[Ömer]

İlk mesajda yanlış anlamışım.

Bir örnek hazırladım, kendi dosyanıza uyarlarsınız.

Sub test()
    
    Dim c As Range, Adr As String, ara As String, j As Byte, d
    
    ara = "geldim"
    ara = UCase(Replace(Replace(ara, "ı", "I"), "i", "İ"))

    Set c = [A:A].Find(ara, LookIn:=xlValues)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            d = Split(c.Value, " ")
            For j = 0 To UBound(d)
                If UCase(Replace(Replace(d(j), "ı", "I"), "i", "İ")) = ara Then
                    MsgBox "aranan değeri buldum"
                    Exit Do
                End If
            Next j
            Set c = [A:A].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If
    
End Sub

 

[search77]

Ömer bey sizi çok yoruyorum farkındayım, ama tam istediğimi anlatamamış olabilirim.
Aslında istediğim ilk yukarıda yazdığım kodun şu mantıkta çalışması
E hücresindeki kelimeleri (e1,e2,e3 ....Eson) gibi tek tek alıp B hücresinde aratmak yani B ye filitre koyduğunuzda filitreyi açıp search kısmına bu kelimeleri yazıp ne kadar hücre yakalarsa bunları sarıya boyaması veya o hücreyi bold yapması gibi
Bilmem anlatabildim mi , ilk yukarıda belirttiğim kod aslında buna yakın çalışıyor ama tam değil

 

[search77]

Ömer bey uğraşmayın lütfen, sizin yazdığınız örnekten birşeyler yaptım işe yaradı elinize kolunuza emeğinize sağlık, çok teşekkürler
Saygılar

 

[Korhan Ayhan]

Alternatif...

 

[search77]

korhan bey elinize emeğinize sağlık çok teşekkürler
saygılar