For loop on unique ID - excel

Sheet1 is a continuous list of everything being recorded and kept.
Sheet2 is an updated list that is retrieved, with updated lines and new lines. Within the lists in column A is a unique ID for every entry in numeric value.
I am trying to go through every unique ID in sheet2, look for a match in sheet1
if there is a match, replace that entire row values with the new values from sheet2
if there is no match it needs to be placed in the last blank row (+1 from xlUp).
I have tried other ways that are not below like using scripting.dictionary.
The way I am trying to do this results in every cell that the “for” is looking at to be true for the if not equal. Every item is posted multiple times below xlUp.
Sub test()
Dim enter As Worksheet
Dim take As Worksheet
Set enter = Worksheets("Sheet1")
Set take = Worksheets("Sheet2")
Dim a1 As Long
Dim b1 As Long
Dim c1 As Long
a1 = take.Cells(Rows.Count, 1).End(xlUp).Row
b1 = enter.Cells(Rows.Count, 1).End(xlUp).Row
c1 = enter.Cells(Rows.Count, 1).End(xlUp).Row + 1
For i = 1 To a1 'this statement works fine to find the matching value to replace.
For K = 1 To b1
If take.Cells(i, 1) = enter.Rows(K, 1) Then
enter.Rows(i).EntireRow = take.Rows(K).EntireRow.Value
End If
Next
Next
'below is other things i have tried
'For I = 1 To a1
' For J = 1 To b1
' If enter.Cells(J, 1) <> take.Cells(I, 1) Then
' enter.Rows(c1).EntireRow = take.Rows(I).EntireRow.Value
' c1 = c1 + 1
' End If
' Next
'Next
'For i = 1 To a1
' For j = 1 To b1
' If take.Cells(i, 1) = enter.Cells(j, 1) Then
' enter.Rows(j).EntireRow = take.Rows(i).EntireRow.Value
' GoTo Skip
' ElseIf j = b1 Then
' enter.Rows(c1).EntireRow = take.Rows(i).EntireRow.Value
' c1 = c1 + 1
' End If
' Next
'Skip:
'Next
End Sub

hy
Public Sub MyCopy()
Dim wsSource As Worksheet, wsTarget As Worksheet
Set wsSource = ThisWorkbook.Worksheets("ws1")
Set wsTarget = ThisWorkbook.Worksheets("ws2")
Dim col As String
col = "A"
Dim i As Long, targetRow As Long, q As Long
Dim sourceRange As Range
With wsSource
For i = 1 To .Cells(.Rows.Count, col).End(xlUp).Row
Set sourceRange = .Range(col & i)
targetRow = GetDataRow(wsTarget, col, sourceRange.value)
For q = 0 To 30
wsTarget.Range(col & targetRow).Offset(0, q).value = sourceRange.Offset(0, q).value
Next q
Next i
End With
End Sub
Private Function GetDataRow(ws As Worksheet, col As String, value As String) As Long
With ws
Dim lastRow As Long, i As Long
lastRow = .Cells(.Rows.Count, col).End(xlUp).Row
For i = 1 To lastRow
If .Range(col & i).value = value Then
GetDataRow = i
GoTo exitFunc
End If
Next i
GetDataRow = lastRow + 1
End With
exitFunc:
End Function

Update Worksheet (For Each ... Next, Application.Match)
Option Explicit
Sub UpdateWorksheet()
Const sName As String = "Sheet2"
Const sFirst As String = "A1"
Const dName As String = "Sheet1"
Const dFirst As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slCell As Range
Set slCell = sws.Cells(sws.Rows.Count, sws.Range(sFirst).Column).End(xlUp)
Dim srg As Range: Set srg = sws.Range(sFirst, slCell)
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dlCell As Range:
Set dlCell = dws.Cells(dws.Rows.Count, dws.Range(dFirst).Column).End(xlUp)
Dim drg As Range: Set drg = dws.Range(dFirst, dlCell)
Application.ScreenUpdating = False
Dim sCell As Range
Dim cIndex As Variant
For Each sCell In srg.Cells
cIndex = Application.Match(sCell.Value, drg, 0)
If IsNumeric(cIndex) Then
drg.Cells(cIndex).EntireRow.Value = sCell.EntireRow.Value
Else
Set dlCell = dlCell.Offset(1)
dlCell.EntireRow.Value = sCell.EntireRow.Value
End If
Next sCell
Application.ScreenUpdating = True
End Sub

Related

Find Matches in Column and Replace from External File

I use this VBA code which works very well. It searches in column A of an external Excel file for all the terms in column D, and replaces the matches, with the content of column B of the external file in the found row. So for instance:
if D5 matches A11 of the external file, then B11 from external file is written to D5.
I am now trying to modify it so that it still searches in column 4 for matches in column A of external file, but for any matches found, replaces the column E with column B of the external file. So:
If D5 matches A11, then B11 from external file is written to E5.
Well, I've tried many changes in the replace loop but it throws errors every time. I suppose I don't use the correct command!
Private Sub CommandButton1_Click()
Dim NameListWB As Workbook, thisWb As Workbook
Dim NameListWS As Worksheet, thisWs As Worksheet
Dim i As Long, lRow As Long
'This is the workbook from where code runs
Set thisWb = ThisWorkbook
Set thisWs = thisWb.Sheets("Sheet1")
'External file
Set NameListWB = Workbooks.Open("E:\Data.xlsx")
Set NameListWS = NameListWB.Worksheets("Sheet1")
With NameListWS
'Detect end row in Col A of Data.xlsx
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'Loop though Column A
For i = 1 To lRow
'... and perform replace action
thisWs.Columns(4).Replace What:=.Range("A" & i).Value, _
Replacement:=.Range("B" & i).Value, _
SearchOrder:=xlByColumns, _
MatchCase:=False
Next i
End With
End Sub ```
Untested:
Private Sub CommandButton1_Click()
Dim NameListWB As Workbook
Dim NameListWS As Worksheet, thisWs As Worksheet, n As Long
Dim i As Long, arrList, arrD, rngD As Range
Set thisWs = ThisWorkbook.Sheets("Sheet1") 'This is the workbook from where code runs
'get an array from the column to be searched
Set rngD = thisWs.Range("D1:D" & thisWs.Cells(Rows.Count, "D").End(xlUp).Row)
arrD = rngD.Value
'Open external file and get the terms and replacements as an array
Set NameListWB = Workbooks.Open("E:\Data.xlsx")
With NameListWB.Worksheets("Sheet1")
arrList = .Range("A1:B" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
End With
For n = 1 To UBound(arrD, 1) 'check each value from ColD
For i = 1 To UBound(arrList, 1) 'loop over the array of terms to search for
If arrD(n, 1) = arrList(i, 1) Then 'exact match ?
'If InStr(1, arrD(n, 1), arr(i, 1)) > 0 Then 'partial match ?
rngD.Cells(n).Offset(0, 1).Value = arrList(i, 2) 'populate value from ColB into ColE
Exit For 'got a match so stop searching
End If
Next i
Next n
End Sub
A VBA Lookup (Application.Match)
Adjust (play with) the values in the constants section.
Compact
Sub VBALookup()
' Source
Const sPath As String = "E:\Data.xlsx"
Const sName As String = "Sheet1"
Const slCol As String = "A" ' lookup
Const svCol As String = "B" ' value
Const sfRow As Long = 2
' Destination
Const dName As String = "Sheet1"
Const dlCol As String = "D" ' lookup
Const dvCol As String = "E" ' value
Const dfRow As Long = 2
Application.ScreenUpdating = False
' Source
Dim swb As Workbook: Set swb = Workbooks.Open(sPath)
Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slCol).End(xlUp).Row
If slRow < sfRow Then Exit Sub ' no data in lookup column range
Dim srCount As Long: srCount = slRow - sfRow + 1
Dim slrg As Range: Set slrg = sws.Cells(sfRow, slCol).Resize(srCount)
Dim svData As Variant
With slrg.EntireRow.Columns(svCol)
If srCount = 1 Then ' one cell
ReDim svData(1 To 1, 1 To 1): svData(1, 1) = .Value
Else ' multiple cells
svData = .Value
End If
End With
' Destination
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(dName)
Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dlCol).End(xlUp).Row
If dlRow < dfRow Then Exit Sub ' no data in lookup column range
Dim drCount As Long: drCount = dlRow - dfRow + 1
Dim dlrg As Range: Set dlrg = dws.Cells(dfRow, dlCol).Resize(drCount)
Dim dData As Variant
If drCount = 1 Then ' one cell
ReDim dData(1 To 1, 1 To 1): dData(1, 1) = dlrg.Value
Else ' multiple cells
dData = dlrg.Value
End If
' Loop.
Dim srIndex As Variant
Dim dValue As Variant
Dim dr As Long
Dim MatchFound As Boolean
For dr = 1 To drCount
dValue = dData(dr, 1)
If Not IsError(dValue) Then
If Len(dValue) > 0 Then
srIndex = Application.Match(dValue, slrg, 0)
If IsNumeric(srIndex) Then MatchFound = True
End If
End If
If MatchFound Then
dData(dr, 1) = svData(srIndex, 1)
MatchFound = False
Else
dData(dr, 1) = Empty
End If
Next dr
' Close the source workbook.
swb.Close SaveChanges:=False
' Write result.
dlrg.EntireRow.Columns(dvCol).Value = dData
' Inform.
Application.ScreenUpdating = True
MsgBox "VBA lookup has finished.", vbInformation
End Sub

if condition only few steps true VBA/Excel

enter image description hereFor a larger project I need to change the source of values for a column all n*k steps, with n being a rational and k a natural number.
Edit for better understanding:
I have a column with multiple entries (filled by a loop in a makro) and need to find all entries with a common divisor called "testwer" in my makro. This "testwer" should later be editable in an excel sheet via a cellinput (in this case G2)
I've tried by writing a macro , a simplified example looks like the following:
Sub testmam()
Dim testwer, i, j
i = 1
j = 1
testwer = Range("g2").Value 'gets the rational number n
Do Until i = 18 'until end of entries in column is reached
If Cells(i, 1).Value = testwer * j Then 'if cellvalue = n*1,2,...,infty
Cells(i, 2).Value = j 'some output in another cell to check wether the detection was sucessfull
j = j + 1 'check coming cells for next value of n*k
End If
i = i + 1
Loop
End Sub
However, when I run this, it only detects the first few (3-5) solutions. For example for n being 1.5 it found only 1.5, 3 and 4.5 to be true. Starting from values 6 to all following multipliers of 1.5 the if condition seems to turn out false.
Does someone know how this could happen? As the if condition is true for multiple steps, I assume the syntax isn't completely wrong.
Greets
Detect Multipliers
Compact
Sub TestMamCompact()
Const wsName As String = "Sheet1"
Const SourceFirstCellAddress As String = "A1"
Const TestCellAddress As String = "G2"
Const DestinationColumn As String = "B"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim sfCell As Range: Set sfCell = ws.Range(SourceFirstCellAddress)
Dim slCell As Range
Set slCell = ws.Cells(ws.Rows.Count, sfCell.Column).End(xlUp)
If slCell.Row < sfCell.Row Then Exit Sub ' no data
Dim srg As Range: Set srg = ws.Range(sfCell, slCell)
Dim TestWert As Double: TestWert = ws.Range(TestCellAddress).Value
Dim k As Long: k = 1
Dim sCell As Range
For Each sCell In srg.Cells
If IsNumeric(sCell) Then
If sCell.Value = TestWert * k Then
ws.Cells(sCell.Row, DestinationColumn).Value = k
k = k + 1
End If
End If
Next sCell
MsgBox "Results written.", vbInformation
End Sub
Argumented
Sub TestMamTEST()
Const wsName As String = "Sheet1"
Const SourceFirstCellAddress As String = "A1"
Const TestCellAddress As String = "G2"
Const DestinationColumn As String = "B"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim sfCell As Range: Set sfCell = ws.Range(SourceFirstCellAddress)
TestMam sfCell, TestCellAddress, DestinationColumn
' or just:
'TestMam sfCell, "G2", "B"
End Sub
Sub TestMamOneLinerTEST()
TestMam ThisWorkbook.Worksheets("Sheet1").Range("A1"), "G2", "B"
End Sub
Sub TestMam( _
ByVal SourceFirstCell As Range, _
ByVal TestCellAddress As String, _
ByVal DestinationColumn As String)
Dim ws As Worksheet: Set ws = SourceFirstCell.Worksheet
Dim slCell As Range
Set slCell = ws.Cells(ws.Rows.Count, SourceFirstCell.Column).End(xlUp)
If slCell.Row < SourceFirstCell.Row Then Exit Sub ' no data
Dim srg As Range: Set srg = ws.Range(SourceFirstCell, slCell)
Dim TestWert As Double: TestWert = ws.Range(TestCellAddress).Value
Dim k As Long: k = 1
Dim sCell As Range
For Each sCell In srg.Cells
If IsNumeric(sCell) Then
If sCell.Value = TestWert * k Then
ws.Cells(sCell.Row, DestinationColumn).Value = k
k = k + 1
End If
End If
Next sCell
MsgBox "Results written.", vbInformation
End Sub

Copy every second value of a row and paste into a column in another sheet

pls help, I need a excel vba code, which copies every second value of a row
and paste that into a column in another sheet
.
I tried it like this
Sub Test()
Worksheets("Sheet1").Activate
Dim x As Integer
For x = 5 To 196 Step 2
Worksheets("Tabelle1").Activate
Cells(x, 2).Value = Sheets("Sheets1").Range("E2:GN2")
Next x
End Sub
Sub test()
Dim WkSource As Worksheet
Dim WkDestiny As Worksheet
Dim i As Long
Dim j As Long
Dim LR As Long
Dim k As Long
Set WkSource = ThisWorkbook.Worksheets("Hoja1")
Set WkDestiny = ThisWorkbook.Worksheets("Hoja2")
With WkSource
LR = .Range("E" & .Rows.Count).End(xlUp).Row
k = 2 'starting row where you want to paste data in destiny sheet
For i = 2 To LR Step 1
For j = 5 To 12 Step 2 'j=5 to 12 because my data goes from column E to L (5 to 12)
WkDestiny.Range("D" & k).Value = .Cells(i, j).Value
k = k + 1
Next j
Next i
End With
Set WkSource = Nothing
Set WkDestiny = Nothing
End Sub
The code loop trough each row and each column (notice step 2 to skip columns)
Output I get:
you can start from something like this:
Option Explicit
Private Sub dataCp()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = wb.Sheets("Tabelle1")
Dim lrow As Long, lcol As Long, i As Long
Dim rng As Range, c As Range
lcol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For i = 5 To lcol
lrow = (ws2.Cells(ws2.Rows.Count, "D").End(xlUp).Row) + 1
ws2.Range("D" & lrow).Value = ws.Cells(2, i).Value
i = i + 1
Next
End Sub
Transpose Data
It will transpose all rows of a range in a worksheet to consecutive columns on another worksheet.
Since scStep is 2, in this case, only every other cell in each source row will be copied.
Adjust (play with) the values in the constants section.
Option Explicit
Sub TransposeData()
' Source
Const sName As String = "Sheet1"
Const sFirstRowAddress As String = "E2:GN2"
Const scStep As Long = 2
' Destination
Const dName As String = "Tabelle1"
Const dFirstCellAddress As String = "D2"
' Both
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Write the values from the source range to the source array.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sData As Variant
Dim srCount As Long
With sws.Range(sFirstRowAddress)
' Populate data.
' With .Resize(20)
' .Formula = "=RANDBETWEEN(1,100)"
' .Value = .Value
' End With
Dim lCell As Range: Set lCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub ' no data in data range
srCount = lCell.Row - .Row + 1
sData = .Resize(srCount).Value
End With
' Define the destination array.
Dim scCount As Long: scCount = UBound(sData, 2)
Dim drCount As Long
drCount = Int(scCount / scStep) - CLng(scCount Mod scStep > 0)
Dim dData As Variant: ReDim dData(1 To drCount, 1 To srCount)
' Write the data from the source array to the destination array.
Dim r As Long, c As Long
For c = 1 To srCount
For r = 1 To drCount
dData(r, c) = sData(c, (r - 1) * scStep + 1)
Next r
Next c
' Write the values from the destination array to the destination range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dFirstCellAddress).Resize(, srCount) ' first row range
' Write data.
.Resize(drCount).Value = dData
' Clear below.
.Resize(dws.Rows.Count - .Row - drCount + 1).Offset(drCount).Clear
' Apply some formatting.
'.EntireColumn.AutoFit
End With
' Inform.
MsgBox "Data transposed.", vbInformation
End Sub

How do I allow duplicates in VBA?

I'm trying to compare column A in sheet2 to column A in sheet1 and when there's a match, copy the row from sheet1 to sheet3 with the same order. And if there is a repetition, it should be included too. I also need it to show the mismatching values empty. I did this macro but I can not allow the duplicates to be included.
Sub compareAndCopy()
Dim lastRowE As Long
Dim lastRowF As Long
Dim lastRowM As Long
Dim foundTrue As Boolean
' stop screen from updating to speed things up
Application.ScreenUpdating = False
lastRowE = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "A").End(xlUp).Row
lastRowF = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row
lastRowM = Sheets("Sheet3").Cells(Sheets("Sheet3").Rows.Count, "B").End(xlUp).Row
For i = 1 To lastRowE
foundTrue = False
For j = 1 To lastRowF
If Sheets("Sheet2").Cells(i, 1).Value = Sheets("Sheet1").Cells(j, 1).Value Then
lastRowM = lastRowM + 1
Sheets("Sheet1").Rows(i).Copy Destination:= _
Sheets("Sheet3").Rows(lastRowM)
foundTrue = True
Exit For
End If
Next j
'If Not foundTrue Then
' MsgBox ("didn't find string: " & Sheets("Sheet2").Cells(i, 2).value)
'End If
Next i
' allow screen updating
Application.ScreenUpdating = True
End Sub
Group Data
Loops through probably unique values in column A of Sheet2.
For each cell value, it uses the Find and FindNext methods to find all the matching cells in column A of Sheet1.
Then it writes each of the cell values to a key, and using Union, combines each matching cell to a range object in the corresponding item.
Then it loops through the dictionary and copies the entire rows of each item (range) to Sheet3.
Finally, it clears the newly added values in column A of Sheet3.
The result in Sheet3 is data from Sheet1 grouped by the values in column A of Sheet2.
Option Explicit
Sub CompareAndCopy()
Const eName As String = "Sheet2"
Const eCol As String = "A"
Const efRow As Long = 1 ' don't you have headers?
Const fName As String = "Sheet1"
Const fCol As String = "A"
Const ffRow As Long = 1 ' don't you have headers?
Const mName As String = "Sheet3"
Const mCol As String = "B" ' "A" is empty!
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ews As Worksheet: Set ews = wb.Worksheets(eName)
Dim elRow As Long: elRow = ews.Cells(ews.Rows.Count, eCol).End(xlUp).Row
If elRow < efRow Then Exit Sub ' no data
Dim erg As Range: Set erg = ews.Cells(efRow, eCol).Resize(elRow - efRow + 1)
'Debug.Print erg.Address
Dim fws As Worksheet: Set fws = wb.Worksheets(fName)
Dim flRow As Long: flRow = fws.Cells(fws.Rows.Count, fCol).End(xlUp).Row
If flRow < ffRow Then Exit Sub ' no data
Dim frg As Range:
Set frg = fws.Cells(ffRow, fCol).Resize(flRow - ffRow + 1)
'Debug.Print frg.Address
Dim mws As Worksheet: Set mws = wb.Worksheets(mName)
Dim mifCell As Range
Set mifCell = mws.Cells(mws.Rows.Count, mCol).End(xlUp).Offset(1) _
.EntireRow.Columns("A") ' entire rows
Dim mfCell As Range: Set mfCell = mifCell
'Debug.Print mfCell.Address
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Application.ScreenUpdating = False
Dim frCount As Long: frCount = frg.Rows.Count
Dim eCell As Range
Dim eValue As Variant
Dim fCell As Range
Dim FirstAddress As String
For Each eCell In erg.Cells
eValue = eCell.Value
Set fCell = frg.Find(eValue, frg.Cells(frCount), xlFormulas, xlWhole)
If Not fCell Is Nothing Then
FirstAddress = fCell.Address
Do
If dict.Exists(eValue) Then
Set dict(eValue) = Union(dict(eValue), fCell)
Else
Set dict(eValue) = fCell
End If
Set fCell = frg.FindNext(fCell)
Loop Until fCell.Address = FirstAddress
End If
Next eCell
If dict.Count = 0 Then Exit Sub ' no data¸
Dim rg As Range
Dim Item As Variant
Dim irCount As Long
For Each Item In dict.Items
irCount = Item.Cells.Count
'Debug.Print Item.Address, irCount
Item.EntireRow.Copy mfCell.EntireRow
Set mfCell = mfCell.Offset(irCount)
Next Item
mifCell.Resize(mfCell.Row - mifCell.Row).ClearContents ' or .Clear
Application.ScreenUpdating = True
MsgBox "Data grouped.", vbInformation
End Sub

Partial match string from a range to another range

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
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
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

Resources