Please help

[lorenzoscott78]

Need help fine tuning my formula.
I am trying to get the exact matches to come up in column C and any partial matches in column D. I am getting the exact matches with no problem. But the partial are not being pulled correctly. In the attached example in RED is what I would like as an outcome for column D.

--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Option Explicit


Sub IdentifyMatches()

Dim lngThisCoreRow As Long
Dim lngLastCoreRow As Long
Dim lngThisInputRow As Long
Dim lngLastInputRow As Long
Dim strInputText As String
Dim strCoreText As String
Dim sCore As String
Dim sInput As String
Dim sExact As String
Dim sPartial As String
Dim strOutcome As String
Dim strInput As String
Dim strCore As String

sCore = "A"
sInput = "B"
sExact = "C"
sPartial = "D"

'Define ValidArea Range
lngLastCoreRow = Range(sCore & "1").End(xlDown).Row
Range(sCore & lngLastCoreRow).Select
If MsgBox("Is this the last row of column " & sCore & "?", vbYesNo) = vbNo Then
Exit Sub
End If
lngLastInputRow = Range(sInput & "1").End(xlDown).Row
Range(sInput & lngLastInputRow).Select
If MsgBox("Is this the last row of this column " & sInput & "?", vbYesNo) = vbNo Then
Exit Sub
End If
'Prep Outcome columns
Range(sExact & "2: " & sExact & lngLastCoreRow).Clear
Range(sPartial & "2: " & sPartial & lngLastCoreRow).Clear
Range(sExact & "2: " & sExact & lngLastInputRow).Clear
Range(sPartial & "2: " & sPartial & lngLastInputRow).Clear
Range(sExact & "2: " & sExact & lngLastInputRow).NumberFormat = "@"
Range(sPartial & "2: " & sPartial & lngLastInputRow).NumberFormat = "@"
Range(sExact & "2: " & sExact & lngLastInputRow).HorizontalAlignment = xlCenter
Range(sPartial & "2: " & sPartial & lngLastInputRow).HorizontalAlignment = xlCenter
'Prep Data
For lngThisCoreRow = 2 To lngLastCoreRow
Range(sCore & lngThisCoreRow) = Trim(Range(sCore & lngThisCoreRow))
Next lngThisCoreRow
For lngThisInputRow = 2 To lngLastInputRow
Range(sInput & lngThisInputRow) = Trim(Range(sInput & lngThisInputRow))
Next lngThisInputRow
'Get Outcomes
For lngThisInputRow = 2 To lngLastInputRow
strInput = UCase(Range(sInput & lngThisInputRow))
For lngThisCoreRow = 2 To lngLastCoreRow
strCore = UCase(Range(sCore & lngThisCoreRow))
If strInput = strCore Then
Range(sExact & lngThisInputRow) = Range(sInput & lngThisInputRow)
Exit For
End If
Next lngThisCoreRow
Next lngThisInputRow
For lngThisInputRow = 2 To lngLastInputRow
If Range(sExact & lngThisInputRow) = "" Then
strOutcome = ""
strInput = UCase(Range(sInput & lngThisInputRow))
Range(sInput & lngThisInputRow).Select
For lngThisCoreRow = 2 To lngLastCoreRow
strCore = UCase(Range(sCore & lngThisCoreRow))
If InStr(strCore, strInput) > 0 Then
strOutcome = strInput
Exit For
End If
Next lngThisCoreRow
If strOutcome <> "" Then
Range(sPartial & lngThisInputRow) = Range(sInput & lngThisInputRow)
End If
End If
Next lngThisInputRow
'Done
Range("C2").Select
Range("A1").Select
MsgBox "Done"

End Sub

[Pepe Le Mokko]

Your post does not comply with Rule 1 of our Forum RULES. Your post title should accurately and concisely describe your problem, not your anticipated solution. Use terms appropriate to a Google search. Poor thread titles, like Please Help, Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will be addressed according to the OP's experience in the forum: If you have less than 10 posts, expect (and respond to) a request to change your thread title. If you have 10 or more posts, expect your post to be locked, so you can start a new thread with an appropriate title.
To change a Title on your post, click EDIT then Go Advanced and change your title, if 2 days have passed ask a moderator to do it for you.