Comprarátor

Sub CompareAndWrite()


    Dim rowNum As Integer
    Dim strA As String, strB As String
    Dim wordsA() As String, wordsB() As String
    Dim matches As String
    Dim foundMatch As Boolean

    rowNum = 1 ' Starting row number

    Do While Range("A" & rowNum).Value <> "" ' Loop until an empty cell is found in column A
        ' Get the values from cells A(rowNum) and B(rowNum)
        strA = Range("A" & rowNum).Value
        strB = Range("B" & rowNum).Value

        ' Split the strings into an array of words
        wordsA = Split(strA, " ")
        wordsB = Split(strB, " ")

        ' Initialize the variables
        matches = ""
        foundMatch = False

        ' Loop through each word in the first string
        For Each wordA In wordsA
            ' Check if the word exists in the second string and is longer then 2 characters
            If InStr(1, strB, wordA, vbTextCompare) > 0 And Len(wordA) > 2 Then
                ' Found a matching word/sentence
                If matches <> "" Then
                    matches = matches & " "
                End If
                matches = matches & wordA
                foundMatch = True
            End If
        Next wordA

        ' Write the matches into the corresponding cell in column C
        If foundMatch Then
            Range("C" & rowNum).Value = matches
        Else
            Range("C" & rowNum).Value = "výraz_nenalezen"
        End If

        rowNum = rowNum + 1 ' Move to the next row
    Loop
End Sub