VBA: Multiple text and number columns. Find list and number of unique words

I have Multiple text/sentences and number in multiple columns. I need to find "list and number" of unique words in next sheet. Then I need to find "list and number" of given sentences. Can anybody help me out ?

Same as your previous thread?

VBA: Find all sentences with a given word. Partial match preferred with regex.

Attach a sample workbook. Make sure there is just enough data to demonstrate your need. Include a BEFORE sheet and an AFTER sheet in the workbook if needed to show the process you're trying to complete or automate. Make sure your desired results are shown, mock them up manually if necessary.

Remember to desensitize the data.

Click on GO ADVANCED and then scroll down to Manage Attachments to open the upload window.

Excel sheet attached. Thank you in advance.

Try

Sub test()
    Dim x, myPtn As String, txt As String, m As Object, e, i As Long, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("Reference phrase or word")
        x = Filter(.[transpose(if(a2:a5000<>"",a2:a5000))], False, 0)
        myPtn = Join(x, Chr(2))
    End With
    For Each e In x
        dic(e) = Empty
    Next
    With Sheets("BEFORE sheet")
        txt = .[a2].Value
        With CreateObject("VBScript.RegExp")
            .Global = True
            .Pattern = "([$()^|\\\[\]{}+*?.-])"
            myPtn = Replace(.Replace(myPtn, "\$1"), Chr(2), "|")
            .Pattern = "\b(" & myPtn & ")\b"
            For Each m In .Execute(txt)
                If IsEmpty(dic(m.Value)) Then dic(m.Value) = m.Value
            Next
        End With
        For Each e In dic
            If IsEmpty(dic(e)) Then dic.Remove e
        Next
        If dic.Count Then
            For i = 1 To dic.Count
                .Cells(1, i * 2).Value = "Exact word: """ & dic.keys()(i - 1) & """"
                .Cells(1, i * 2 + 1).Value = "Similar to word: """ & dic.items()(i - 1) & """"
            Next
        End If
    End With
End Sub

Not working

..........................

Hmm the "BEFORE sheet" Column A has data. After the macro has ran successfully the result should be as in "AFTER sheet1". In AFTER sheet1 output data should be like in column B - G; until there are keys left. Hope its clear now. For each key there are two column. One for exact match and another for partial match. So sentences are copied as per key.

Thank you again but the output is not matching with the "AFTER sheet1" columns.
words from same row with matching key should be grouped in same row.
For each key there are two columns column: Exact word: "XXXXXX" & column: Similar to word: "XXXXXX" Please check the output in AFTER sheet1 for key "win".
Moreover if I change any key it seems its not working.
Please ignore small letter capital letter issue.

OK, I think I understand what you are trying to do now.
Then I need a clear definition of difference between "Exact" & "Similar" words.

Sub test()
    Dim x, y, myPtn As String, txt As String, i As Long
    Dim rng As Range, r As Range, mtch As Object, m As Object
    Application.ScreenUpdating = False
    With Sheets("Reference phrase or word")
        x = Filter(.[transpose(if(a2:a5000<>"",a2:a5000))], False, 0)
    End With
    With Sheets("BEFORE sheet")
        .Rows(1).HorizontalAlignment = xlCenter
        .Rows(1).VerticalAlignment = xlCenter
        With .Range("b1").Resize(Rows.Count, Columns.Count - 1)
            .ClearContents
            .WrapText = True
            .VerticalAlignment = xlTop
        End With
        ReDim y(UBound(x) * 2 + 1)
        For i = 0 To UBound(x)
            y(i * 2) = x(i): y(i * 2 + 1) = x(i)
            If x(i) Like "* *" Then y(i * 2 + 1) = Split(x(i))(0)
            .Cells(1, i * 2 + 2).Value = "Exact word: """ & x(i) & """"
            .Cells(1, i * 2 + 3).Value = "Simi;ar to word: """ & x(i) & """"
        Next
        Set rng = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
        With CreateObject("VBScript.RegExp")
            .Global = True: .IgnoreCase = True
            .Pattern = "([$()^|\\\[\]{}*+?.-])"
            For i = 0 To UBound(y)
                If i Mod 2 Then
                    y(i) = "(\S" & y(i) & "|" & y(i) & "[^ .])"
                Else
                    y(i) = "\b" & y(i) & "\b(?!\S)"
                End If
            Next
            For Each r In rng
                txt = r.Value
                .Pattern = "[^\r\n.]+?(\.|$)"
                Set mtch = .Execute(txt)
                For Each m In mtch
                    For i = 0 To UBound(y)
                        .Pattern = y(i)
                        If .test(m.Value) Then
                            r(, i + 2).Value = r(, i + 2).Value & _
                            IIf(r(, i + 2).Value <> "", vbLf, "") & Trim$(m.Value)
                        End If
                            
                    Next
                Next
            Next
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Thank you very much again from the core of my heart. It didn't cached the data from cell A4.

Try replace the code with this one

Sub test()
    Dim x, y, myPtn As String, txt As String, i As Long
    Dim rng As Range, r As Range, mtch As Object, m As Object
    Application.ScreenUpdating = False
    With Sheets("Reference phrase or word")
        x = Filter(.[transpose(if(a2:a5000<>"",a2:a5000))], False, 0)
    End With
    With Sheets("BEFORE sheet")
        .Rows(1).HorizontalAlignment = xlCenter
        .Rows(1).VerticalAlignment = xlCenter
        With .Range("b1").Resize(Rows.Count, Columns.Count - 1)
            .ClearContents
            .WrapText = True
            .VerticalAlignment = xlTop
        End With
        ReDim y(UBound(x) * 2 + 1)
        For i = 0 To UBound(x)
            y(i * 2) = x(i): y(i * 2 + 1) = x(i)
            If x(i) Like "* *" Then y(i * 2 + 1) = Split(x(i))(0)
            .Cells(1, i * 2 + 2).Value = "Exact word: """ & x(i) & """"
            .Cells(1, i * 2 + 3).Value = "Simi;ar to word: """ & x(i) & """"
        Next
        Set rng = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
        With CreateObject("VBScript.RegExp")
            .Global = True: .IgnoreCase = True
            .Pattern = "([$()^|\\\[\]{}*+?.-])"
            For i = 0 To UBound(y)
                If i Mod 2 Then
                    y(i) = "(\S" & y(i) & "|" & y(i) & "[^ .])"
                Else
                    y(i) = "\b" & y(i) & "([ ,](.+)|[?.!]$)"
                End If
            Next
            For Each r In rng
                txt = r.Value
                .Pattern = "[^\r\n]+?([?!]|\.(?=( |\n|$)))"
                Set mtch = .Execute(txt)
                For i = 0 To UBound(y)
                    .Pattern = y(i)
                    For Each m In mtch
                        If .test(m.Value) Then
                            r(, i + 2).Value = r(, i + 2).Value & _
                            IIf(r(, i + 2).Value <> "", vbLf, "") & Trim$(m.Value)
                        End If
                    Next
                Next
            Next
        End With
    End With
    Application.ScreenUpdating = True
End Sub

With same condition's -- if I want to get the same kind of result with with two or more cell data making a pair with one another in reference then ?

Originally Posted by first_jaguar

With same condition's -- if I want to get the same kind of result with with two or more cell data making a pair with one another in reference then ?

I don't understand what you are asking.

Found a bug in the previous code.

Sub test()
    Dim x, y, myPtn As String, txt As String, i As Long
    Dim rng As Range, r As Range, mtch As Object, m As Object
    Application.ScreenUpdating = False
    With Sheets("Reference phrase or word")
        x = Filter(.[transpose(if(a2:a5000<>"",a2:a5000))], False, 0)
    End With
    With Sheets("BEFORE sheet")
        .Rows(1).HorizontalAlignment = xlCenter
        .Rows(1).VerticalAlignment = xlCenter
        With .Range("b1").Resize(Rows.Count, Columns.Count - 1)
            .ClearContents
            .WrapText = True
            .VerticalAlignment = xlTop
        End With
        ReDim y(UBound(x) * 2 + 1)
        For i = 0 To UBound(x)
            y(i * 2) = x(i): y(i * 2 + 1) = x(i)
            If x(i) Like "* *" Then y(i * 2 + 1) = Split(x(i))(0)
            .Cells(1, i * 2 + 2).Value = "Exact word: """ & x(i) & """"
            .Cells(1, i * 2 + 3).Value = "Similar to word: """ & x(i) & """"
        Next
        Set rng = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
        With CreateObject("VBScript.RegExp")
            .Global = True: .IgnoreCase = True
            .Pattern = "([$()^|\\\[\]{}*+?.-])"
            For i = 0 To UBound(y)
                If i Mod 2 Then
                    y(i) = "(\S" & y(i) & "|" & y(i) & "([^ .]|\.\S))"
                Else
                    y(i) = "\b" & y(i) & "\.?(?!\S)"
                End If
            Next
            For Each r In rng
                txt = r.Value
                .Pattern = "([?.])(?!\S)"
                txt = .Replace(txt, "$1" & vbLf)
                .Pattern = "[^\r\n]+"
                Set mtch = .Execute(txt)
                For Each m In mtch
                    For i = 0 To UBound(y)
                        .Pattern = y(i)
                        If .test(m.Value) Then
                            r(, i + 2).Value = r(, i + 2).Value & _
                            IIf(r(, i + 2).Value <> "", " ", "") & Trim$(m.Value)
                        End If
                    Next
                Next
            Next
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Still not sure.

If you upload a workbook showing before/after, it would help.

Here it is.

Dear Jindon now I need to work the previous code to run in multiple sheet.

It will be too much work for free forum, so I suggest you to go to Commercial Services where you will get prompt reply quickly.