Partial match string from a range to another range - excel

Question

I'm trying to return the partial match string on a column right beside the column with the text I'm trying to search within. This is the code I tried to write. What would be a better way to do this?
Essentially I have a column with:
Column 1
aaaaa1111
...
zzzzz9999
Column 2
aaa
bbb
..
zzz
I want to return column 2 values to the column adjacent to column 1 where the column 2's string can be found within column 1.
Sub match()
Dim ws As Worksheet
Dim vendors As Range
Dim description As Range
Dim match As Range
Dim cell As Range
Dim j As Integer
Dim i As Integer
Set vendors = ws.Range("ae2:ae1007").Text
Set description = ws.Range("o2:o32609")
Set match = ws.Range("p2:p32609")
For i = 2 To 32609
For j = 2 To 1007
If InStr(description.Cells(i, "O"), vendors.Range(j, "AE")) > 0 Then
match.Cells(i, "P") = vendors.Range(j, "AE").Text
Else: match.Cells(i, "P") = "#N/A"
End If
Next j
Next i
End Sub
Update: (I get run-time error '91' on line 9)
Sub match()
Dim ws As Worksheet
Dim cell As Range
Dim j As Integer
Dim i As Integer
For i = 2 To 32609
For j = 2 To 1007
If InStr(ws.Cells(i, "O"), ws.Cells(j, "AE")) > 0 Then
ws.Cells(i, "P") = ws.Cells(j, "AE").Text
Else: ws.Cells(i, "P") = "#N/A"
End If
Next j
Next i
End Sub

Answer 1

You are getting error 91 because you declared ws but did not set ws to any worksheet.
The code below should run pretty fast since it process the data in an array (read/write from cells is a very slow process).
Option Explicit
Sub FindMatch()
Const vendorCol As String = "AE"
Const descCol As String = "O"
Const matchCol As String = "P"
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Change name accordingly
'==== Get a list of unique vendor names
Dim vendorDict As Object
Set vendorDict = CreateObject("Scripting.Dictionary")
vendorDict.CompareMode = vbTextCompare
Dim vendorLastRow As Long
Dim vendorInput As Variant
'Assign the values of the vendor names to array
vendorLastRow = ws.Cells(ws.Rows.Count, vendorCol).End(xlUp).Row
vendorInput = ws.Range(ws.Cells(2, vendorCol), ws.Cells(vendorLastRow, vendorCol)).Value
'Loop through the array and add to dictionary if it's not already in it
Dim n As Long
For n = 1 To UBound(vendorInput, 1)
If Not vendorDict.Exists(vendorInput(n, 1)) Then vendorDict.Add vendorInput(n, 1), 1
Next n
Dim vendorArr As Variant
vendorArr = vendorDict.keys
Set vendorDict = Nothing
Erase vendorInput
'====
'Assign the values of description to array
Dim descLastRow As Long
Dim descArr As Variant
descLastRow = ws.Cells(ws.Rows.Count, descCol).End(xlUp).Row
descArr = ws.Range(ws.Cells(2, descCol), ws.Cells(descLastRow, descCol)).Value
'Create an array of the same size as the description for match result, will be used to write in to the worksheet once at the end
Dim matchArr() As Variant
ReDim matchArr(1 To UBound(descArr, 1), 1 To 1) As Variant
'Loop through the description array and within the loop, check if there's a match in the vendor array
Dim i As Long
For i = 1 To UBound(descArr, 1)
For n = 0 To UBound(vendorArr)
If InStr(1, descArr(i, 1), vendorArr(n), vbTextCompare) <> 0 Then
'If match found, assign the vendor name to the match array
matchArr(i, 1) = vendorArr(n)
Exit For
End If
Next n
'If no match, return NA error
If matchArr(i, 1) = vbNullString Then matchArr(i, 1) = CVErr(xlErrNA)
Next i
ws.Cells(2, matchCol).Resize(UBound(matchArr, 1)).Value = matchArr
Erase descArr
Erase matchArr
End Sub

Answer 2

Compare Two Columns
This is a basic example that loops through column O and compares each value against each value in column AE. Match is no good because the values in AE need to be contained in O. You can always improve efficiency by using arrays as illustrated in Raymond Wu's answer.
On the other hand, you could loop through column AE and use the Find and FindNext methods to find all matches in column O which might also be more efficient.
Option Explicit
Sub MatchVendors()
' s - Source (read from ('vendors'))
' d - Destination (read from ('description') and written to ('match'))
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1") ' adjust, often...
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet1") ' ... different
Dim slRow As Long: slRow = sws.Range("AE" & sws.Rows.Count).End(xlUp).Row
If slRow < 2 Then Exit Sub ' no data in source
Dim srg As Range: Set srg = sws.Range("AE2:AE" & slRow)
Dim dlRow As Long: dlRow = dws.Range("O" & dws.Rows.Count).End(xlUp).Row
If dlRow < 2 Then Exit Sub ' no data in destination
Dim drg As Range: Set drg = dws.Range("O2:O" & dlRow)
Application.ScreenUpdating = False
Dim sCell As Range
Dim dCell As Range
Dim IsMatch As Boolean
For Each dCell In drg.Cells
' Read (Search)
For Each sCell In srg.Cells
' Either 'contains'...
If InStr(1, dCell.Value, sCell.Value, vbTextCompare) > 0 Then
' ... or 'begins with':
'If InStr(1, dCell.Value, sCell.Value, vbTextCompare) = 1 Then
IsMatch = True
Exit For
End If
Next sCell
' Write
If IsMatch Then
dCell.EntireRow.Columns("P").Value = sCell.Value
IsMatch = False
Else
dCell.EntireRow.Columns("P").Value = "#N/A"
End If
Next dCell
Application.ScreenUpdating = True
MsgBox "Vendors matched to Descriptions.", vbInformation
End Sub