Soru İki hücre arasında benzerlerin sayısını bulma

[Eda_mavi122223]

Merhabalar,

A1 hücresinde: bu akşam maç izleyeceğiz.
B1 hücresinde: bu akşam dizi izleyeceğiz.
yazmaktadır.

Bu durumda C1 hücresine aynı olan kelimelerin sayısını nasıl yazdırabilirim? Yani; "bu, akşam, izleyeceğiz" üçü de ortak kelimeler. Dolayısıyla C1 hücresine 3 yazsın.
Mümkün mü bilmiyorum.
Lütfen acil yardımınız gerekli

 

[muygun]

Merhaba;
Makro çözümlü Ekleri deneyin.
İyi çalışmalar.

Link:
https://s6.dosya.tc/server2/f3g5fx/Eda_mavi122223-benzer_kelime_say.zip.html
https://s6.dosya.tc/server2/tszaln/Eda_mavi122223-benzer_kelime_say-1.zip.html

 

[Eda_mavi122223]

Merhaba;
Makro çözümlü Ekleri deneyin.
İyi çalışmalar.

Link:
https://s6.dosya.tc/server2/f3g5fx/Eda_mavi122223-benzer_kelime_say.zip.html
https://s6.dosya.tc/server2/tszaln/Eda_mavi122223-benzer_kelime_say-1.zip.html

Merhaba
dosyayı açamadım çünkü başka bir bilgisyara uygulamalıyım bu formülü kendi bilgisayarım açmıyor, abonelik süresi doldu.
Makro formülünü kopyalayıp yorumda paylaşabilir misiniz?

 

[muygun]

Sub işlem()
Application.ScreenUpdating = False
On Error Resume Next
Dim aranankelime
Range("c1:c65536").ClearContents
For k = 1 To Range("A65536").End(xlUp).Row
say = 0
kolon = Split(Cells(k, 1).Value, " ")
For i = 0 To UBound(kolon)
aranankelime = Trim(kolon(i))
If InStr(Trim(Cells(k, "b")), Trim(aranankelime)) >= 1 Then
say = say + 1
End If
Cells(k, "c") = say

'Renklendirme kodları başlangıcı
sonn = Range("b65536").End(xlUp).Row
With Range("b" & k)
kelimee = aranankelime
Set c = .Find(kelimee, Lookat:=xlPart)
If Not c Is Nothing Then
bul = c.Address
Do
c.Characters(Start:=InStr(UCase(c.Value), UCase(kelimee)), Length:=Len(kelimee)).Font.ColorIndex = 3
Set c = .FindNext(c)
If c Is Nothing Then Exit Do
Loop While Not c Is Nothing And c.Address <> bul
End If
End With
'Renklendirme kodları sonu

Next i
Next k
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub

Sub renklendirmeyi_kaldır()
Application.ScreenUpdating = False
On Error Resume Next
Columns("B:B").Select
Selection.Font.ColorIndex = 0
Range("f1").Select
Application.ScreenUpdating = True

End Sub

 

[Eda_mavi122223]

Sub işlem()
Application.ScreenUpdating = False
On Error Resume Next
Dim aranankelime
Range("c1:c65536").ClearContents
For k = 1 To Range("A65536").End(xlUp).Row
say = 0
kolon = Split(Cells(k, 1).Value, " ")
For i = 0 To UBound(kolon)
aranankelime = Trim(kolon(i))
If InStr(Trim(Cells(k, "b")), Trim(aranankelime)) >= 1 Then
say = say + 1
End If
Cells(k, "c") = say

'Renklendirme kodları başlangıcı
sonn = Range("b65536").End(xlUp).Row
With Range("b" & k)
kelimee = aranankelime
Set c = .Find(kelimee, Lookat:=xlPart)
If Not c Is Nothing Then
bul = c.Address
Do
c.Characters(Start:=InStr(UCase(c.Value), UCase(kelimee)), Length:=Len(kelimee)).Font.ColorIndex = 3
Set c = .FindNext(c)
If c Is Nothing Then Exit Do
Loop While Not c Is Nothing And c.Address <> bul
End If
End With
'Renklendirme kodları sonu

Next i
Next k
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub

Sub renklendirmeyi_kaldır()
Application.ScreenUpdating = False
On Error Resume Next
Columns("B:B").Select
Selection.Font.ColorIndex = 0
Range("f1").Select
Application.ScreenUpdating = True

End Sub

Öncelikle formül için çok çok teşekkür ederim. ve bir desteğinize daha ihtiyacım var:

Mesela "T.C. ZİRAAT BANKASI İSTANBUL ŞUBE" ile "TÜRKİYE CUMHURİYETİ ZİRAAT BANKASI" arasında olan benzer kelimeleri bulurken T.C. ile TÜRKİYE CUMHURİYETİNİN aynı anlama geldiğini bilip bunu da renklendireceğimiz ek bir formül var mı?

 

[muygun]

Merhaba;
Makro ile birebir eşleşen verileri bulup renklendirmek mümkün.
Bunun için ekte olduğu gibi eşleştirme veri tabanı oluşturmalısınız.
A sütununda verileriniz , C sütununda bulunması halinde renklenecek veri tabanınız varsa;

Sub kelime_renklendir()
Cells.Font.ColorIndex = xlAutomatic
sonn = Range("a65536").End(xlUp).Row
With Range("a1:a" & sonn)
For i = 1 To Range("c65536").End(xlUp).Row
kelimee = Cells(i, "c")
Set c = .Find(kelimee, Lookat:=xlPart)
If Not c Is Nothing Then
bul = c.Address
Do
c.Characters(Start:=InStr(UCase(c.Value), UCase(kelimee)), Length:=Len(kelimee)).Font.ColorIndex = 3
Set c = .FindNext(c)
If c Is Nothing Then Exit Do
Loop While Not c Is Nothing And c.Address <> bul
End If
Next i
End With
End Sub

Sub renklendirme_iptal()
Columns("A:A").Select
Selection.Font.ColorIndex = 0
Range("A1").Select
End Sub

Ayrıca son isteğinizin konu başlığı ile alakası yok. Yeni bir başlıkta sorunuzu yöneltmeniz daha yerinde olur.