Soru Hücreler arası ortak kelime 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

 

[mesudiye_052]

Merhabalar

Option Explicit
Sub harfBul()

Dim ws As Worksheet
Dim cll As Range
Dim arr1() As Variant
Dim arr2() As Variant
Dim arr3() As Variant
Dim str1() As String
Dim str2() As String
Dim lr, i, j, k As Long
Dim sayac, adet As Integer


Set ws = ThisWorkbook.ActiveSheet
lr = ws.Cells(Rows.Count, "A").End(xlUp).row

ReDim arr1(1 To lr, 1 To 1)
ReDim arr2(1 To lr, 1 To 1)
ReDim arr3(1 To lr, 1 To 1)

arr1 = ws.Range("A1:A" & lr + 1)
arr2 = ws.Range("B1:B" & lr + 1)

For i = LBound(arr1) To UBound(arr1)
    str1 = Split(Application.Trim(UCase(Replace(Replace(arr1(i, 1), "ı", "I"), _
    "i", "İ"))))
    
    str2 = Split(Application.Trim(UCase(Replace(Replace(arr2(i, 1), "ı", "I"), _
    "i", "İ"))))
    
    For j = LBound(str1) To UBound(str1)
       sayac = 0
       For k = LBound(str2) To UBound(str2)
            If str1(j) = str2(k) Then
                 sayac = sayac + 1
            End If
       Next k
       If sayac > 0 Then
            arr3(i, 1) = arr3(i, 1) & " " & str1(j)
            adet = adet + 1
       End If
    Next j
    On Error Resume Next
    arr3(i, 1) = arr3(i, 1) & " " & adet & " Adet"
    On Error GoTo 0
Next i
ws.Range("C1:C" & lr) = arr3

Set ws = Nothing
Set cll = Nothing
Erase arr1
Erase arr2
Erase arr3

End Sub

 

[EmrExcel16]

Alternatif..

Option Explicit
Sub Kelime_Adet()
Dim e, m, r, Veri, Bul, Say
    For e = 1 To Cells(Rows.Count, 1).End(3).Row
        Say = 0
        Veri = Split(Cells(e, 1), " ")
        For m = 0 To UBound(Veri)
            Bul = Split(Cells(e, 2), " ")
            For r = 0 To UBound(Bul)
                If Bul(r) = Veri(m) Then
                    Say = Say + 1
                End If
            Next
        Next
        Cells(e, 3) = Say
    Next
End Sub

 

[mesudiye_052]

Merhabalar;

Kodda bir kod eksik yazdım
güncel hali ektedir.

Option Explicit
Sub harfBul()

Dim ws As Worksheet
Dim cll As Range
Dim arr1() As Variant
Dim arr2() As Variant
Dim arr3() As Variant
Dim str1() As String
Dim str2() As String
Dim lr, i, j, k As Long
Dim sayac, adet As Integer


Set ws = ThisWorkbook.ActiveSheet
lr = ws.Cells(Rows.Count, "A").End(xlUp).row

ReDim arr1(1 To lr, 1 To 1)
ReDim arr2(1 To lr, 1 To 1)
ReDim arr3(1 To lr, 1 To 1)

arr1 = ws.Range("A1:A" & lr + 1)
arr2 = ws.Range("B1:B" & lr + 1)

For i = LBound(arr1) To UBound(arr1)
    str1 = Split(Application.Trim(UCase(Replace(Replace(arr1(i, 1), "ı", "I"), _
    "i", "İ"))))
    
    str2 = Split(Application.Trim(UCase(Replace(Replace(arr2(i, 1), "ı", "I"), _
    "i", "İ"))))
    adet = 0
    For j = LBound(str1) To UBound(str1)
       sayac = 0
       For k = LBound(str2) To UBound(str2)
            If str1(j) = str2(k) Then
                 sayac = sayac + 1
            End If
       Next k
       If sayac > 0 Then
            arr3(i, 1) = arr3(i, 1) & " " & str1(j)
            adet = adet + 1
       End If
    Next j
    On Error Resume Next
    arr3(i, 1) = arr3(i, 1) & " " & adet & " Adet"
    On Error GoTo 0
Next i
ws.Range("C1:C" & lr) = arr3

Set ws = Nothing
Set cll = Nothing
Erase arr1
Erase arr2
Erase arr3

End Sub

 

[Korhan Ayhan]

Alternatif;

Kullanıcı tanımlı fonksiyon kullanımı;

=EŞLEŞEN_KELİME_SAY(A1;B1)

Eşleştirme yaparken noktalama işaretlerini gözardı ederek kontrol eder. Büyük-küçük harf duyarlı değildir. Yani AHMET=ahmet olarak değerlendirme yapar.

Option Explicit

Function EŞLEŞEN_KELİME_SAY(Metin_1 As Range, Metin_2 As Range)
    Dim Dizi As Object, Kelime As Variant, Say As Long
    Dim Kelime_Say_1 As Long, Kelime_Say_2 As Long
    Dim Aranan_1 As String, Aranan_2 As String
    
    Application.Volatile True
    
    Kelime_Say_1 = Len(Metin_1.Value) - Len(Replace(Metin_1.Value, " ", ""))
    Kelime_Say_2 = Len(Metin_2.Value) - Len(Replace(Metin_2.Value, " ", ""))
    
    If Kelime_Say_1 >= Kelime_Say_2 Then
        Aranan_1 = Metin_1.Value
        Aranan_2 = Metin_2.Value
    Else
        Aranan_1 = Metin_2.Value
        Aranan_2 = Metin_1.Value
    End If
    
    With CreateObject("Scripting.Dictionary")
        For Each Kelime In Split(Aranan_1, " ")
            Kelime = Noktalama_Pasif(Kelime)
            If Not .Exists(Kelime) Then .Add Kelime, Nothing
        Next
    
        For Each Kelime In Split(Aranan_2, " ")
            Kelime = Noktalama_Pasif(Kelime)
            If .Exists(Kelime) Then Say = Say + 1
        Next
    End With

    EŞLEŞEN_KELİME_SAY = Say
End Function

Function Noktalama_Pasif(ByVal Metin As String)
    Dim Noktalama As Variant
    
    Noktalama_Pasif = UCase(Replace(Replace((Metin), "ı", "I"), "i", "İ"))
    
    For Each Noktalama In Array("...", ".", "-", "—", "/", "\", "(", ")", "[", "]", "{", "}", """", "'", ",", ":", ";", "!", "?")
        Noktalama_Pasif = Replace(Noktalama_Pasif, Noktalama, "")
    Next
End Function

 

[52779]

Selamlar,
Formülle çözüm olarak eki inceleyebilirsiniz...

KelimeAdet_Karsilastir.xlsx dosyasını indir - download

KelimeAdet_Karsilastir.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s7.dosya.tc

Excel 2013 ve üzerinde geçerli olmak üzere (XMLFİLTRELE işlevi 2013 ve sonrası için mevcuttur)

A1 : Ocak ayında Pazartesi günleri Hasan Çarşamba günleri ise Mesut çalışacak
B1 : Şubat ayında ise Pazartesi Mustafa Çarşamba Hasan

şeklinde yazıyor olsun....

C1 hücresine

=TOPLA.ÇARPIM(--ESAYIYSA(KAÇINCI(XMLFİLTRELE("<b><a>"&YERİNEKOY(KIRP(A1);" ";"</a><a>")&"</a></b>";"/b/a["&SATIR(DOLAYLI("1:"&1+UZUNLUK(KIRP(A1))-UZUNLUK(YERİNEKOY(KIRP(A1);" ";""))))&"]");XMLFİLTRELE("<b><a>"&YERİNEKOY(KIRP(B1);" ";"</a><a>")&"</a></b>";"/b/a["&SATIR(DOLAYLI("1:"&1+UZUNLUK(KIRP(B1))-UZUNLUK(YERİNEKOY(KIRP(B1);" ";""))))&"]");0)))

yazarak 5 sonucunu bulabilirsiniz.

Önemli Not :
1 - Kelimeler arasında birden fazla boşluk olabilir.
2 - Formülde Noktalama işaretleri değerlendirmeye alınmamıştır.
Değerlendirmeye alınacaksa formülde A1 ve hem de B1 yazan yerlere
YERİNEKOY(YERİNEKOY(YERİNEKOY(YERİNEKOY(YERİNEKOY(A1;",";"");".";"");";";"");":";"");"?";"").........
(şeklinde tüm noktalama işaretlerini de kapsayacak şekilde YERİNEKOY işlemleri yazılarak bu ifade tamamlanır)
gibi bir formül parçası yazılabilir. Formül zaten uzun bir de bunlar eklenirse çok uzun olacaktır.