Compare strings in a cell no matter the sequence - string

Question

I am looking some help with a code to compare 2 strings and rank them in accordance of their matching with the original criteria. The code should ignore the sequence, For example, A1 contains words "Jon Smith" (original value), and B1 "Smith Jon", which are the same ranking. But if C1 contains "Jon Smith Junior", this should have a lower rank than "Jon Smith" or "Smith Jon".
Any one can help?

Answer 1

StackOverflow is not a coding service, and you should provide your code, but in this case I was interested in the task. Here is a possible solution.
Run the checkme - it simply takes the two strings and splits them into arrays. Then it counts how many times the values in arrOne present in arrTwo. With this information, it gives some kind of a result.
Option Explicit
Public Function CompareTwo(strOne As String, strTwo As String) As Double
Dim arrOne As Variant
Dim arrTwo As Variant
Dim varOne As Variant
Dim varTwo As Variant
Dim lngCounter As Long
arrOne = Split(strOne)
arrTwo = Split(strTwo)
For Each varOne In arrOne
For Each varTwo In arrTwo
If varOne = varTwo Then
lngCounter = lngCounter + 1
End If
Next varTwo
Next varOne
CompareTwo = lngCounter / (UBound(arrOne) + 1)
End Function
Public Sub CheckMe()
Debug.Print CompareTwo("Smith Jon", "Jon Smith")
Debug.Print CompareTwo("Jon Smith Junior", "Jon Smith")
Debug.Print CompareTwo("Jon Smith Junior Ale 6", "Jon Smith Ale 6")
End Sub

Answer 2

I came up with this one. It creates two arrays, one where the two key names are found within a given cell in Column B, and another with how many words are in each array element of arr1. Then it sends the two arrays to a Sort2 Sub, which was written by member Gary's Student and can be found here. It presumes the multiple choice names are in column "B" and that "Jon" and "Smith" are hardcoded - but can be drawn from another column with a little change to the code.
Column B contains:
Jon Smith
Smith Jon Junior
Smith Jon
Sub create2arr()
Dim myArr() As Variant, name1 As String, name2 As String, firstMarker As Boolean, myArrayCounter As Long, myArray2Counter As Long
Dim splitArr() As String, wordCountArr() As Variant
name1 = "Jon"
name2 = "Smith"
ReDim myArr(1 To 1)
ReDim myArr2(1 To 1)
ReDim wordCountArr(1 To 1)
myArrayCounter = 1
myArray2Counter = 1
For I = 1 To 3
splitArr = Split(Sheet6.Range("B" & I))
For J = LBound(splitArr) To UBound(splitArr)
If UCase(splitArr(J)) = UCase(name1) Or UCase(splitArr(J)) = UCase(name2) Then
If firstMarker = True Then
myArr(myArrayCounter) = Sheet6.Range("B" & I)
wordCountArr(myArrayCounter) = UBound(splitArr) + 1
myArrayCounter = myArrayCounter + 1
ReDim Preserve myArr(1 To myArrayCounter)
ReDim Preserve wordCountArr(1 To myArrayCounter)
firstMarker = False
Else
firstMarker = True
End If
End If
Next J
Next I
For I = 1 To UBound(myArr)
Debug.Print myArr(I)
Next I
Call sort2(wordCountArr, myArr)
For I = 1 To UBound(myArr)
Debug.Print myArr(I)
Next I
End Sub
Sub sort2(key() As Variant, other() As Variant)
Dim I As Long, J As Long, Low As Long
Dim Hi As Long, Temp As Variant
Low = LBound(key)
Hi = UBound(key)
J = (Hi - Low + 1) \ 2
Do While J > 0
For I = Low To Hi - J
If key(I) > key(I + J) Then
Temp = key(I)
key(I) = key(I + J)
key(I + J) = Temp
Temp = other(I)
other(I) = other(I + J)
other(I + J) = Temp
End If
Next I
For I = Hi - J To Low Step -1
If key(I) > key(I + J) Then
Temp = key(I)
key(I) = key(I + J)
key(I + J) = Temp
Temp = other(I)
other(I) = other(I + J)
other(I + J) = Temp
End If
Next I
J = J \ 2
Loop
End Sub