Find a multi string match in Column A

AliGW said:

CROSS POST


This question has been posted in at least one other forum.

Do not post any further responses in this thread until a link has been provided to these cross posts.


Whilst we would rather you didn't cross-post, we know that there may be a valid reason for doing so. All we ask is that you provide the links in your original post to your question in the other forum(s). Read this to understand why: https://www.excelguru.ca/content.php?184

This forum is full of volunteers that give up their own time to help others, something that should be respected and not taken for granted. It’s never nice for someone to find out that a problem they have spent time solving for you has already been answered somewhere else without them knowing, and so we ask you to make it clear that you have also asked elsewhere.
Please provide the link(s). If you are unable to do so, tell us where else you have posted this query.

Click to expand...

p45cal said:

test:

Code:

Sub blah()
Set rngToCheck = Range("A2:A35")    'adjust this as required.
rngToCheck.Offset(, 1).Value = "No Duplicate"
rngToCheck.Offset(, 1).Hyperlinks.Delete
For Each cll In rngToCheck.Cells
  If cll.Offset(, 1).Value = "No Duplicate" Then
    MatchNo = 2
    cllWords = Split(Application.Trim(cll.Value))
    cllWordCount = UBound(cllWords) + 1
    If cllWordCount > 2 Then
      Set remainingCells = Nothing
      On Error Resume Next
      Set remainingCells = Intersect(rngToCheck, cll.Offset(1).Resize(rngToCheck.Rows.Count))
      On Error GoTo 0
      If Not remainingCells Is Nothing Then
        For Each celle In remainingCells
          celleWords = Split(Application.Trim(celle.Value))
          celleWordCount = UBound(celleWords) + 1
          If celleWordCount = cllWordCount Then
            myCount = 0
            cllWordsX = cllWords
            For i = LBound(cllWordsX) To UBound(cllWordsX)
              For j = LBound(celleWords) To UBound(celleWords)
                If Len(cllWordsX(i)) > 0 And Len(cllWordsX(i)) > 0 And LCase(cllWordsX(i)) = LCase(celleWords(j)) Then
                  myCount = myCount + 1
                  cllWordsX(i) = Empty: celleWords(j) = Empty
                  Exit For
                End If
              Next j    'celleWord
            Next i    'cllWord
            If myCount = cllWordCount Then
              cll.Offset(, 1).Value = 1
              celle.Offset(, 1).Value = MatchNo
              
              'disable the next line if you don't want hyperlinks:
              ActiveSheet.Hyperlinks.Add Anchor:=celle.Offset(, 1), Address:="", SubAddress:=cll.Address

              'Enable only ONE of the next two lines:
              MatchNo = MatchNo + 1    'enable this one to keep  searching for more matches and number them accordingly, 2,3,4 etc.
              'Exit For    'enabling this line instead will stop searching after the first match is found.
            
            End If
          End If
        Next celle
      End If
    End If
  End If
Next cll
End Sub

Click to expand...