Check for similarities within a single cell-CodePudding

Does anyone knows how to higlight similar words within a single cell? What I want to achieve is to find duplicates/similar words between < ; > in a cell.

example cell:

home;music;car;window;musician

desired result:

music in a word musician is hilglighted or the output is 'TRUE' in the next column if similar word like this has been found.

I was able to compare words between two columns but not within single cell.

So far I was able to create a formula to separate the words in the cell to have each range separate to work with.

Function IdDuplicates(rng As Range) As String
Dim StringtoAnalyze As Variant
Dim I As Integer
Dim J As Integer
Const minWordLen As Integer = 4
StringtoAnalyze = Split(UCase(rng.Value), ";")
For I = UBound(StringtoAnalyze) To 0 Step -1
If Len(StringtoAnalyze(I)) < minWordLen Then GoTo SkipA
For J = 0 To I - 1
If StringtoAnalyze(J) = StringtoAnalyze(I) Then
IdDuplicates = "TRUE"
GoTo SkipB
End If
Next J
SkipA:
Next I
IdDuplicates = "FALSE"
SkipB:
End Function

Any ideas?

CodePudding user response：

This function returns either FALSE or a list of the similar words

Option Explicit

Function IdDuplicates(rng As Range) As String

    Dim s As String, word, m As Object, i As Long
    With CreateObject("VBScript.RegExp")
        .IgnoreCase = True
        .Global = True
        s = Trim(rng.Value2)
        For Each word In Split(s, ";")
            .Pattern = word
            Set m = .Execute(s)
            If m.Count > 1 Then
                IdDuplicates = IdDuplicates & "," & word
            End If
        Next
    End With
    If IdDuplicates = "" Then
        IdDuplicates = "FALSE"
    Else
        IdDuplicates = Mid(IdDuplicates, 2) ' remove lead ,
    End If
   
End Function

CodePudding user response：

Match Partially in Delimited String

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a boolean indicating whether any of the substrings
'               in a delimited string is contained in another substring.
' Example:      'music;car;musician' - 'music' is found in 'musician' - TRUE
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function MatchPart( _
    ByVal DelimitedString As Variant, _
    Optional ByVal StringDelimiter As String = ";") _
As Boolean
    
    Dim S As String: S = CStr(DelimitedString)
    Dim Substrings() As String
    Substrings = Split(DelimitedString, StringDelimiter)
    Dim sUpper As Long: sUpper = UBound(Substrings)
    If sUpper < 1 Then Exit Function
    
    Dim i As Long, j As Long, iPos As Long
    Dim iSub As String, jSub As String
    
    For i = 0 To sUpper - 1
        iSub = Substrings(i)
        For j = i   1 To sUpper
            jSub = Substrings(j)
            'Debug.Print i, iSub, j, jSub
            If Len(iSub) <= Len(jSub) Then
                If InStr(1, jSub, iSub, vbTextCompare) > 0 Then
                    MatchPart = True
                    Exit Function
                End If
            Else
                If InStr(1, iSub, jSub, vbTextCompare) > 0 Then
                    MatchPart = True
                    Exit Function
                End If
            End If
        Next j
    Next i

End Function