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
