Soru Kelime Farklılıklarını Buldurma

[hakki83]

Değerli hocalarım selamlar

A sütunundaki ve B sütunundaki yazıları makroyla karşılaştırıp, iki taraftaki eksik kelimeleri (ortak olmayan kelimeleri) makroyla buldurabilir miyiz?

 

[YUSUF44]

Aşağıdaki makroları bir modüle yapıştırıp farklar makrosunu deneyin (virgül ve nokta haricinde noktalama varsa kodda değişiklik yapmak gerekir):

Sub farklar()
son = Cells(Rows.Count, "A").End(3).Row
Range("C1:D" & son).ClearContents
For i = 1 To son
    bakA = Split(Replace(Replace(Cells(i, "A"), ",", ""), ".", ""))
    bakB = Split(Replace(Replace(Cells(i, "B"), ",", ""), ".", ""))
    For j = 0 To UBound(bakA)
        If IsInArray(bakA(j), bakB) = False Then
            If Cells(i, "C") = "" Then
                Cells(i, "C") = "A" & i & " hücresinde olup B" & i & " hücresinde olmayan kelime(ler):" & Chr(10) & bakA(j)
            Else
                Cells(i, "C") = Cells(i, "C") & ", " & bakA(j)
            End If
        End If
    Next
    For k = 0 To UBound(bakB)
        If IsInArray(bakB(k), bakA) = False Then
            If Cells(i, "D") = "" Then
                Cells(i, "D") = "B" & i & " hücresinde olup A" & i & " hücresinde olmayan kelime(ler):" & Chr(10) & bakB(k)
            Else
                Cells(i, "D") = Cells(i, "D") & ", " & bakB(k)
            End If
        End If
    Next
Next
End Sub
Private Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
'DEVELOPER: Ryan Wells (wellsr.com)
'DESCRIPTION: Function to check if a value is in an array of values
'INPUT: Pass the function a value to search for and an array of values of any data type.
'OUTPUT: True if is in array, false otherwise
Dim element As Variant
On Error GoTo IsInArrayError: 'array is empty
    For Each element In arr
        If element = valToBeFound Then
            IsInArray = True
            Exit Function
        End If
    Next element
Exit Function
IsInArrayError:
On Error GoTo 0
IsInArray = False
End Function

 

[YUSUF44]

Aşağıdaki gibi daha iyi oldu sanki:

Sub farklar()
Set regexp = CreateObject("VBscript.RegExp")
regexp.Global = True
regexp.Pattern = "[^ A-Za-zĞÜŞİÖÇığüşöç]"

'veri = CStr(regexp.Replace(veri.Value, ""))
 
son = Cells(Rows.Count, "A").End(3).Row
Range("C1:D" & son).ClearContents
For i = 1 To son
    bakA = Split(CStr(regexp.Replace(Cells(i, "A").Value, "")), " ")
    bakB = Split(CStr(regexp.Replace(Cells(i, "B").Value, "")), " ")
    
'    bakA = Split(Replace(Replace(Cells(i, "A"), ",", ""), ".", ""))
'    bakB = Split(Replace(Replace(Cells(i, "B"), ",", ""), ".", ""))
    For j = 0 To UBound(bakA)
        If IsInArray(bakA(j), bakB) = False Then
            If Cells(i, "C") = "" Then
                Cells(i, "C") = "A" & i & " hücresinde olup B" & i & " hücresinde olmayan kelime(ler):" & Chr(10) & bakA(j)
            Else
                Cells(i, "C") = Cells(i, "C") & ", " & bakA(j)
            End If
        End If
    Next
    For k = 0 To UBound(bakB)
        If IsInArray(bakB(k), bakA) = False Then
            If Cells(i, "D") = "" Then
                Cells(i, "D") = "B" & i & " hücresinde olup A" & i & " hücresinde olmayan kelime(ler):" & Chr(10) & bakB(k)
            Else
                Cells(i, "D") = Cells(i, "D") & ", " & bakB(k)
            End If
        End If
    Next
Next
End Sub
Private Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
'DEVELOPER: Ryan Wells (wellsr.com)
'DESCRIPTION: Function to check if a value is in an array of values
'INPUT: Pass the function a value to search for and an array of values of any data type.
'OUTPUT: True if is in array, false otherwise
Dim element As Variant
On Error GoTo IsInArrayError: 'array is empty
    For Each element In arr
        If element = valToBeFound Then
            IsInArray = True
            Exit Function
        End If
    Next element
Exit Function
IsInArrayError:
On Error GoTo 0
IsInArray = False
End Function

 

[Muzaffer Ali]

Merhaba.
Alternatif olsun.
A da olup B de olmayanlar C Sütununa
B de olup A da olmayanlar D sütununa sıralanıyor.

Sub test()
    Dim Bak As Long
    Dim Kelimeler As Variant
    Dim BakKelime As Integer
    For Bak = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        Kelimeler = Split(Cells(Bak, "A"), " ")
        For BakKelime = 0 To UBound(Kelimeler)
            If Cells(Bak, "B").Find(what:=Kelimeler(BakKelime), lookat:=xlPart) Is Nothing Then
                If Cells(Bak, "C") = "" Then
                    Cells(Bak, "C") = Kelimeler(BakKelime)
                Else
                    Cells(Bak, "C") = Cells(Bak, "C") & ", " & Kelimeler(BakKelime)
                End If
            End If
        Next
        Kelimeler = Split(Cells(Bak, "B"), " ")
        For BakKelime = 0 To UBound(Kelimeler)
            If Cells(Bak, "A").Find(what:=Kelimeler(BakKelime), lookat:=xlPart) Is Nothing Then
                If Cells(Bak, "D") = "" Then
                    Cells(Bak, "D") = Kelimeler(BakKelime)
                Else
                    Cells(Bak, "D") = Cells(Bak, "D") & ", " & Kelimeler(BakKelime)
                End If
            End If
        Next
    Next
End Sub

 

[Haluk]

Alternatif olarak DAO-SQL kullanılabilir, herhangi bir döngü kullanmaya ihtiyaç kalmaz...

.

 

[hakki83]

Değerli hocalarım emeklerinize sağlık, teşekkürler, kodlarınız çok güzel çalışıyor. Yusuf44 hocamın kodlarında ikisinde de sorun yok. Sadece MuzafferAli ve Haluk hocamın kodlarında hazır kelimesinin yanında nokta olduğu için ayrı kelimelermiş gibi algılıyor. Bunu dikkate alacağım. Teşekkür ederim emekleriniz için. Sorun çözülmüştür.

 

[Haluk]

Noktalama işaretlerini Yusuf Bey'in 3 No'lu mesajındaki gibi "RegEx" ile kaldırırsak, önerdiğim kod şöyle kullanılabilir;

Sub Test()
'   Haluk - 12/05/2022
'   sa4truss@gmail.com
   
    Sheets("Detay").Range("A1:D" & Rows.Count).ClearContents
   
    Set regExp = CreateObject("VBscript.RegExp")
    regExp.Global = True
    regExp.Pattern = "[^ A-Za-zĞÜŞİÖÇığüşöç]"
   
    str1 = regExp.Replace(Sheets("Sayfa1").Range("A1"), "")
    str2 = regExp.Replace(Sheets("Sayfa1").Range("B1"), "")
   
    size1 = Len(str1) - Len(Replace(str1, " ", ""))
    size2 = Len(str2) - Len(Replace(str2, " ", ""))
   
    Sheets("Detay").Range("A1:A" & size1 + 1) = Application.Transpose(Split(str1))
    Sheets("Detay").Range("B1:B" & size2 + 1) = Application.Transpose(Split(str2))
   
    Set daoDBEngine = CreateObject("DAO.DBEngine.120")
    Set Db = daoDBEngine.OpenDatabase(ThisWorkbook.FullName, False, False, "Excel 8.0; HDR=No; IMEX=1;")
   
    strSQL = "Select Table2.F2 " & _
             "From [Detay$] as Table2 " & _
             "Left Join " & _
             "[Detay$] As Table1 " & _
             "On Table1.F1 = Table2.F2 Where Table1.F1 Is Null"
   
    Set RS = Db.OpenRecordset(strSQL)
    Sheets("Detay").Range("C1").CopyFromRecordset RS
   
    strSQL = "Select Table1.F1 " & _
             "From [Detay$] as Table1 " & _
             "Left Join " & _
             "[Detay$] As Table2 " & _
             "On Table1.F1 = Table2.F2 Where Table2.F2 Is Null"
   
    Set RS = Db.OpenRecordset(strSQL)
    Sheets("Detay").Range("D1").CopyFromRecordset RS
   
    Sheets("Detay").Activate
End Sub

.