Check cell range for closest match of cell value (multiple words)

Hi Marcus,

Try the following Macro which is included in the attached file. This should get us started. I have no idea what you want in Columns 'C' and Column 'D' and I don't know how to get (and/or calculate) those values:

Option Explicit
Option Compare Text   'Instr Case Insensitive Compare

Sub ClearColumnE()
  Range("E:E").ClearContents
End Sub

Sub CreateListsOfMatches()

  Dim myDictionary As Object

  Dim myRange As Range
  Dim r As Range
    
  Dim i As Long
  Dim iLastIndex As Long
  Dim iLastRowUsedInColumnB As Long
  Dim iMatchCount As Long
  Dim iPos As Long
  Dim iRow As Long
  
  Dim a() As String
  Dim sRange As String
  Dim sSourcePhrase As String
  Dim sToken As String
  Dim sValueColumnB As String
  
  '''''''''''''''''''''''''''''''''''''''''''''''''''
  'Initialization
  '''''''''''''''''''''''''''''''''''''''''''''''''''
  
  'Create the Source dictionary object
  'KEY:   Data Word
  'ITEM:  Count of Data word in Source Phrase (Usually 1)
  Set myDictionary = CreateObject("scripting.dictionary")
  myDictionary.CompareMode = vbTextCompare 'case insensitive
  
  'Clear the Destination Area
  Call ClearColumnE
  
  '''''''''''''''''''''''''''''''''''''''''''''''''''
  'Create the Source Phrase and the List of Source Words
  '''''''''''''''''''''''''''''''''''''''''''''''''''
  
  'Get the Source Phrase (remove leading and trailing spaces)
  sSourcePhrase = Trim(Range("A1").Value)
    
  'Parse the Source Phrase Into Words
  iLastIndex = LjmParseString(sSourcePhrase, a)
  
  'Put the Words in the Source Dictionary
  For i = 0 To iLastIndex
 
    'Process each string and put it into the dictionary and/or increment the count for that item
    sToken = a(i)
    If myDictionary.exists(sToken) Then
      myDictionary.Item(sToken) = myDictionary.Item(sToken) + 1
    Else
      myDictionary.Add sToken, 1
    End If
  Next i
  
  
  '''''''''''''''''''''''''''''''''''''''''''''''''''
  'Process One Data Row at a time
  '''''''''''''''''''''''''''''''''''''''''''''''''''
  
  'Find the Last Row Used In Column 'B'
  iLastRowUsedInColumnB = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

  'Create the Range that is used in Column 'B'
  sRange = "B1:B" & iLastRowUsedInColumnB
  Set myRange = Range(sRange)
  
  For Each r In myRange
  
    'Get the Row Number
    iRow = r.Row
  
    'Get the Phrase to be tested (remove leading and trailing spaces)
    sValueColumnB = Trim(r.Value)
    
    'Parse the Target Phrase Into Words
    iLastIndex = LjmParseString(sValueColumnB, a)
    
    'Try to match the entire phrase (case Insensitive)
    'Put the results in Column 'E' if a match
    iPos = InStr(sValueColumnB, sSourcePhrase)
    If iPos > 0 Then
      Cells(iRow, "E").Value = "Entire Phrase Match"
    Else
    
      'Initialize the Match Count
      iMatchCount = 0
    
      'Find the Number of Matches in the Phrase to be tested
      For i = 0 To iLastIndex
        sToken = a(i)
        If myDictionary.exists(sToken) Then
          iMatchCount = iMatchCount + 1
        End If
      Next i
      
      'Output the Results
      If iMatchCount = 1 Then
        Cells(iRow, "E").Value = "1 Match"
      Else
        Cells(iRow, "E").Value = iMatchCount & " Matches"
      End If
    End If
  
  
  Next r
  
  
  'Clear the object pointers
  Set myDictionary = Nothing
  Set myRange = Nothing

End Sub

Function LjmParseString(InputString As String, ByRef sArray() As String) As Integer
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' This parses a space delimited string into an array of tokens.
' Leading and trailing spaces are stripped from the string in the process.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  Dim i As Integer
  Dim LastNonEmpty As Integer
  Dim iSplitIndex As Integer

 'Initialization
  LastNonEmpty = -1
  
  'Split the string into tokens (space delimited)
  sArray = Split(InputString, " ")
  iSplitIndex = UBound(sArray)

 'Remove the null tokens
  For i = 0 To iSplitIndex
  
    'Remove leading and trailing spaces
    sArray(i) = Trim(sArray(i))
    
    If sArray(i) <> "" Then
       'Get rid of all the whitespace
        LastNonEmpty = LastNonEmpty + 1
        sArray(LastNonEmpty) = sArray(i)
    End If
  Next i


 'Return the number of indices
  LjmParseString = LastNonEmpty
  
End Function

The solution uses a 'Scripting Dictionary' which is useful when you have a list of items that must be compared in no special order. For additional information see: http://www.snb-vba.eu/VBA_Dictionary_en.html

Lewis