Soru Vba ile ortak kelimeleri bul yana yaz

[Eda_mavi122223]

Arkadalar selam,
Iki sütunda sırasıyla bulunan cümlelerin ortak kelime sayısını veren makroyu aşağıda yazdım. Ortak kelimeleri kırmızı ile renklendirmesini de gösterdim. Ama bana ortak kelimeleri bir sonraki sütuna sırasıyla atmasını istiyorum.
Nasıl yapabiliriz,
Şimdiden çok teşekkürler

Ornek hücreler,
A1: Petek Pastanesi B1: Deniz Pastnesi
Bu durumda ortak kelimeleri c sütununa atacak
C1: Pastanesi
Yazacak bir koda ihtiyacım var

"""""""""""""""""""
Sub işlem()
Application.ScreenUpdating = False
On Error Resume Next

Range("dl:ıv65536").ClearContents
Range("dl:ıv65536").Interior.ColorIndex = xlNone

For k = 1 To Range("A65536").End(xlUp).Row
süt = 4
kolon = Split(Cells(k, 1).Value, " ")
For i = 0 To UBound(kolon)
Cells(k, süt) = Trim(kolon(i))
süt = süt + 1
Next i
Next k

For k = 1 To Range("A65536").End(xlUp).Row
süt = Cells(k, 256).End(xlToLeft).Column + 1
kolon = Split(Cells(k, 2).Value, " ")
For i = 0 To UBound(kolon)
Cells(k, süt) = Trim(kolon(i))
süt = süt + 1
Next i
Next k

For i = 1 To Range("A65536").End(xlUp).Row
For k = 4 To Cells(i, 256).End(xlToLeft).Column
aranan = Cells(i, k)
If WorksheetFunction.CountIf(Range("d" & i & ":ıv" & i), Cells(i, k)) >= 2 Then
Cells(i, k).Interior.ColorIndex = 3
End If
Next k
Next i

For i = 1 To Range("A65536").End(xlUp).Row
say = 0
For k = 4 To Cells(i, 256).End(xlToLeft).Column
If Cells(i, k).Interior.ColorIndex = 3 Then
say = say + 1
End If
Next k
Cells(i, 3) = say / 2
Next i
End Sub

Sub temizle()
Range("dl:ıv65536").ClearContents
Range("dl:ıv65536").Interior.ColorIndex = xlNone
End Sub

 

[Eda_mavi122223]

Arkadalar selam,
Iki sütunda sırasıyla bulunan cümlelerin ortak kelime sayısını veren makroyu aşağıda yazdım. Ortak kelimeleri kırmızı ile renklendirmesini de gösterdim. Ama bana ortak kelimeleri bir sonraki sütuna sırasıyla atmasını istiyorum.
Nasıl yapabiliriz,
Şimdiden çok teşekkürler

Ornek hücreler,
A1etek Pastanesi B1eniz Pastanesi
Bu durumda ortak kelimeleri c sütununa atacak
C1: Pastanesi
Yazacak bir koda ihtiyacım var

"""""""""""""""""""
Sub işlem()
Application.ScreenUpdating = False
On Error Resume Next

Range("dl:ıv65536").ClearContents
Range("dl:ıv65536").Interior.ColorIndex = xlNone

For k = 1 To Range("A65536").End(xlUp).Row
süt = 4
kolon = Split(Cells(k, 1).Value, " ")
For i = 0 To UBound(kolon)
Cells(k, süt) = Trim(kolon(i))
süt = süt + 1
Next i
Next k

For k = 1 To Range("A65536").End(xlUp).Row
süt = Cells(k, 256).End(xlToLeft).Column + 1
kolon = Split(Cells(k, 2).Value, " ")
For i = 0 To UBound(kolon)
Cells(k, süt) = Trim(kolon(i))
süt = süt + 1
Next i
Next k

For i = 1 To Range("A65536").End(xlUp).Row
For k = 4 To Cells(i, 256).End(xlToLeft).Column
aranan = Cells(i, k)
If WorksheetFunction.CountIf(Range("d" & i & ":ıv" & i), Cells(i, k)) >= 2 Then
Cells(i, k).Interior.ColorIndex = 3
End If
Next k
Next i

For i = 1 To Range("A65536").End(xlUp).Row
say = 0
For k = 4 To Cells(i, 256).End(xlToLeft).Column
If Cells(i, k).Interior.ColorIndex = 3 Then
say = say + 1
End If
Next k
Cells(i, 3) = say / 2
Next i
End Sub

Sub temizle()
Range("dl:ıv65536").ClearContents
Range("dl:ıv65536").Interior.ColorIndex = xlNone
End Sub

.

 

[muygun]

Merhaba;
Daha önce bir üyemize yaptığım uygulamadaki kodları modifiye ettim.
Eki deneyin.
İyi çalışmalar.

Link:
https://s2.dosya.tc/server17/kh9q5w/Eda_mavi122223-benzer_kelime_bul_renklendir.zip.html

 

[Necdet]

Merhaba,
Doğru mu anladım bilmiyorum ama aşağıdaki kodları dener misiniz?

Sub OrtakSozcukBul()

    Dim i   As Long, _
        j   As Integer, _
        k   As Integer, _
        d   As Variant
    
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
    
        k = 2
        
        d = Split(Cells(i, "A"), " ")
        
        For j = 0 To UBound(d)
            If InStr(Cells(i, "B"), d(j)) > 0 Then
                k = k + 1
                Cells(i, k) = d(j)
            End If
        Next j
        
    Next i
    
End Sub

 

[Eda_mavi122223]

Merhaba;
Daha önce bir üyemize yaptığım uygulamadaki kodları modifiye ettim.
Eki deneyin.
İyi çalışmalar.

Link:
https://s2.dosya.tc/server17/kh9q5w/Eda_mavi122223-benzer_kelime_bul_renklendir.zip.html

Çok çok teşekkürler

 

[Eda_mavi122223]

Merhaba,
Doğru mu anladım bilmiyorum ama aşağıdaki kodları dener misiniz?
Ekli dosyayı görüntüle 236721

Sub OrtakSozcukBul()

    Dim i   As Long, _
        j   As Integer, _
        k   As Integer, _
        d   As Variant
    
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
    
        k = 2
        
        d = Split(Cells(i, "A"), " ")
        
        For j = 0 To UBound(d)
            If InStr(Cells(i, "B"), d(j)) > 0 Then
                k = k + 1
                Cells(i, k) = d(j)
            End If
        Next j
        
    Next i
    
End Sub

Çok teşekkürler bir önceki yorum sorunumu çözdü yine de teşekkürler