Excel VBA/Macro to fetch consecutive Duplicate words in multiple cells of a column selection

 Select the data/column and run the Macro, It will fetch the consecutive duplicate words and add them in the next column for each cell. The word with length more than 2 included and another exception is that they shouldn't be ending with comma.

Sub FetchConsecutiveDuplicates()

    Dim rng As Range

    Dim cell As Range

    Dim words() As String

    Dim i As Long

    Dim startPos As Long

    Dim endPos As Long

    Dim duplicates As String

    

    ' Select the column where you want to check for consecutive duplicates

    Set rng = Selection

    For Each cell In rng

        If Not IsEmpty(cell.Value) Then

            words = Split(cell.Value, " ")

            startPos = 1

            duplicates = ""

            

            For i = LBound(words) + 1 To UBound(words)

                If LCase(words(i)) = LCase(words(i - 1)) Then ' Compare words case-insensitively

                    endPos = InStr(startPos, cell.Value, words(i), vbTextCompare)

                    

                    ' Check if the word meets the criteria

                    If Len(words(i)) >= 3 And Right(words(i), 1) <> "," Then

                        ' Append the duplicate word to the duplicates string

                        duplicates = duplicates & words(i) & " "

                    End If

                    

                    startPos = endPos + Len(words(i)) + 1 ' Move the starting position to the next word

                End If

            Next i

            

            ' Paste the consecutive duplicate words in the next column's cell

            If duplicates <> "" Then

                cell.Offset(0, 1).Value = Trim(duplicates)

            End If

        End If

    Next cell

End Sub