Verilerin Ayrıştırılması:

[akmlyx]

Verilerin Ayrıştırılması:

Değerli Arkadaşlar Merhaba,
A2 ve B2 hücrelerine yazılmış olan metinler bulunmaktadır. Söz konusu metinlerin ortak kelimeleri ve farklı kelimeleri mevcut olup, bu kelimelerin ayrıştırılması gerekmektedir. C2 hücresine iki metnin ortak kelimeleri, D2 hücresine A2 hücresinde olup B2 hücresinde olmayan kelimeleri, E2 hücresine de B2 hücresinde olup A2 hücresinde olmayan kelimelerin yazılmasını istiyorum.
İlginiz için şimdiden Teşekkür ederim.

ÖRNEK:
Ekte mevcuttur.

 

[Emir Hüseyin Çoban]

. . .

Güzel farklı bir soru.
Cümlelerde değişik noktalama işaretleri olabilir mi.
virgül, soru işareti gibi...

. . .

 

[veyselemre]

Eski ve yeni metinde birden fazla tekrar eden kelime olmaması lazım.

Sub vEmre()
    eski = Split([a2], " ")
    yeni = Split([b2], " ")
    With CreateObject("Scripting.Dictionary")
        For Each elem In eski
            key = Replace(elem, ".", "")
            x0 = .Item(key) - 1
            .Item(key) = x0
        Next elem
        For Each elem In yeni
            key = Replace(elem, ".", "")
            x0 = .Item(key) + 1
            .Item(key) = x0
        Next elem

        t = ""
        For Each elem In eski
            key = Replace(elem, ".", "")
            If .Item(key) = 0 Then
                t = t & elem & " "
            Else
                t = t & "... "
            End If
        Next elem
        [c2] = Trim(t)

        t = ""
        For Each elem In eski
            key = Replace(elem, ".", "")
            If .Item(key) = -1 Then
                t = t & elem & " "
            Else
                t = t & "... "
            End If
        Next elem
        [d2] = Trim(t)

        t = ""
        For Each elem In yeni
            key = Replace(elem, ".", "")
            If .Item(key) = 1 Then
                t = t & elem & " "
            Else
                t = t & "... "
            End If
        Next elem
        [e2] = Trim(t)
    End With
End Sub

 

[akmlyx]

Değerli Hocalarım Merhaba, daha önceki bir tarihte "verilerin ayrıştırılması" ile ilgili bir makro talep etmiştim, Veyselemre hocam sağolsun yukarıda bulunan makroyu yazdı. Kendisine TEŞEKKÜR EDİYORUM. Yukarıdaki makroda da görüldüğü üzere sadece a2 ve b2 hücrelerdeki metinler için çalışıyor, Bana gerekli olan ise a3 ve b3 hücrelerdeki, a4 ve b4 hücrelerdeki, ... a1000 ve b1000 hücrelerdeki metinleri ayrıştırmak için de çalışmasını istiyorum. Acaba bu mümkün müdür? Yardımlarınız için şimdiden çok TEŞEKKÜR EDİYORUM.

 

[Korhan Ayhan]

Döngüye alarak yapabilirsiniz.

Sub vEmre()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Son = Cells(Rows.Count, 1).End(3).Row

    For X = 2 To Son
        eski = Split(Cells(X, 1).Value, " ")
        yeni = Split(Cells(X, 2).Value, " ")
        With CreateObject("Scripting.Dictionary")
            For Each elem In eski
                Key = Replace(elem, ".", "")
                x0 = .Item(Key) - 1
                .Item(Key) = x0
            Next elem
            For Each elem In yeni
                Key = Replace(elem, ".", "")
                x0 = .Item(Key) + 1
                .Item(Key) = x0
            Next elem
    
            t = ""
            For Each elem In eski
                Key = Replace(elem, ".", "")
                If .Item(Key) = 0 Then
                    t = t & elem & " "
                Else
                    t = t & "... "
                End If
            Next elem
            Cells(X, 3).Value = Trim(t)
    
            t = ""
            For Each elem In eski
                Key = Replace(elem, ".", "")
                If .Item(Key) = -1 Then
                    t = t & elem & " "
                Else
                    t = t & "... "
                End If
            Next elem
            Cells(X, 4).Value = Trim(t)
    
            t = ""
            For Each elem In yeni
                Key = Replace(elem, ".", "")
                If .Item(Key) = 1 Then
                    t = t & elem & " "
                Else
                    t = t & "... "
                End If
            Next elem
            Cells(X, 5).Value = Trim(t)
        End With
    Next
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[YUSUF44]

Cepten, denemeden yazıyorum:

Sub satırından sonra

For i = 1 to 1000

Satırı ekleyin

End sub satırından önce

Next

Satırı ekleyin.

Kodda [B2] yerine

cells(i, "B")

[C2] and yerine

Cells(i, "C")

[D2] yerine

Cells(i, "D")

[E2] yerine

Cells(i, "E")

Yazın.

 

[akmlyx]

Korhan Ayhan hocam emeğiniz için çok TEŞEKKÜR EDERİM. Yazdığınız makro çok güzel çalıştı. Yusuf44 hocam size de çok TEŞEKKÜR EDERİM, Korhan hocamın yazdığı makro çalışınca sizinkini denemedim.