Application Match Function how to copy paste data - excel

Using Application.Match Function but unable to know how to paste the Col"M" data into Col"P" after the Matching the Col"O" and Col"L".
When run the Current function it gives the count of match.
Any help will be appreciated.
Dim k As Integer
For k = 2 To 9
ws2.Cells(k, 16).Value = Application.Match(ws2.Cells(k, 15).Value, ws2.Range("L2:L9"), 0)
Next k
I have edited the code with the columns and in which column the result is required. But unable to make changes I really appreciate your help that you make this function. I added some comments may it can help.
' Sheet2 Col"C" with ID's
With ws2
Dim lastRow As Long
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Dim originalData() As Variant
originalData = .Range("C2:C" & lastRow).Value
End With
' Sheet2 Col"C" with ID's
With ws3
Dim lastRow2 As Long
lastRow2 = .Range("A" & .Rows.Count).End(xlUp).Row
Dim newData() As Variant
newData = .Range("C2:C" & lastRow2).Value
End With
Dim i As Long
For i = LBound(newData, 1) To UBound(newData, 1)
Dim j As Long
For j = LBound(originalData, 1) To UBound(originalData, 2)
If newData(i, 1) = originalData(j, 1) Then
newData(i, 2) = originalData(j, 2)
Exit For
End If
Next
Next
'Sheet2 Col"K" where Sheet3 Col"E" data will be pasted
ws2.Range("K2:K" & lastRow).Value = newData

A scripting dictionary which maps "keys" to "values" is typically the fastest approach when you need to perform a lot of lookups. It's a bit more code to write but should be quick.
Sub DoLookup()
Dim arrKeys, arrValues, wsData As Worksheet, wsDest As Worksheet
Dim map As Object, rngSearch As Range, rngResults As Range, k, v, n As Long
Set wsData = ThisWorkbook.Worksheets("Sheet3") 'sheet with the lookup table
Set wsDest = ThisWorkbook.Worksheets("Sheet2") 'sheet to be populated
arrKeys = wsData.Range("C2:C" & LastRow(wsData, "C")).Value 'keys in the lookup table
arrValues = wsData.Range("G2:G" & LastRow(wsData, "C")).Value 'values in the lookup table
Set map = MapValues(arrKeys, arrValues) 'get a map of Keys->Values
Set rngSearch = wsDest.Range("C2:C" & LastRow(wsDest, "c")) 'keys to look up
Set rngResults = rngSearch.EntireRow.Columns("K") 'results go here
arrKeys = rngSearch.Value 'keys to look up
arrValues = rngResults.Value 'array to populate with results
For n = 1 To UBound(arrKeys) 'loop over keys to look up
v = "" 'or whatever you want to see if no match
k = arrKeys(n, 1)
If map.exists(k) Then v = map(k)
arrValues(n, 1) = v
Next n
rngResults.Value = arrValues 'populate the results array back to the sheet
End Sub
'Return a Scripting Dictionary linking "keys" to "values"
' Note - assumes same-size single-column inputs, and that keys are unique,
' otherwise you just map to the *last* value for any given key
Function MapValues(arrKeys, arrValues)
Dim n, dict As Object, k
Set dict = CreateObject("scripting.dictionary")
For n = 1 To UBound(arrKeys, 1)
k = CStr(arrKeys(n, 1)) 'string keys are faster to add?
If Len(k) > 0 Then dict(k) = arrValues(n, 1)
Next n
Set MapValues = dict
End Function
'utility function
Function LastRow(ws As Worksheet, col As String) As Long
LastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).Row
End Function
In my test workbook this was able to perform 10k lookups against a table of 10k rows in <0.1 sec.

You always should test if the Match succeeded, using IsError.
Then use Cells:
Dim k As Long
For k = 2 To 9
Dim m As Variant
m = Application.Match(ws2.Cells(k, 15).Value, ws2.Range("L2:L9"), 0)
If Not IsError(m) Then
ws2.Cells(k, 16).Value = ws2.Range("M2:M9").Cells(m)
End If
Next

Related

Comparing two lists with different lengths

I want to compare two ID lists with different lengths. The first list is longer and has Values, while the second has no Values.
When the ID's match, it should paste the Value in the first list to the appropriate place beside list 2.
Sub compareList()
Dim v1, v2, v4, v3()
Dim i As Long
Dim j As Long
v1 = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
v2 = Range("B2", Range("B" & Rows.Count).End(xlUp)).Value
v4 = Range("D2", Range("D" & Rows.Count).End(xlUp)).Value
ReDim v3(1 To 4)
For i = LBound(v1) To UBound(v1)
If IsError(Application.Match(v1(i, 1), v4, 0)) Then
j = j + 1
Else
v3(j) = v2(i, 1)
End If
Next i
Range("E2").Resize(i) = Application.Transpose(v3)
End Sub
It gives me an out of index error, or pastes the value in the order it reads it (without paying attention to the match).
If you do not like Vlookup and need some VBA code, please test the next code:
Sub compareList()
Dim sh As Worksheet, lastR As Long, lastR2 As Long, i As Long, j As Long, arr, arrFin
Set sh = ActiveSheet
lastR = sh.Range("A" & rows.count).End(xlUp).row
lastR2 = sh.Range("D" & rows.count).End(xlUp).row
arr = sh.Range("A2:B" & lastR).Value
arrFin = sh.Range("D2:E" & lastR2).Value
For i = 1 To UBound(arrFin)
For j = 1 To UBound(arr)
If arrFin(i, 1) = arr(j, 1) Then arrFin(i, 2) = arr(j, 2): Exit For
Next j
Next i
sh.Range("D2:E" & lastR2).Value = arrFin
End Sub
Just continuing on and referring to #FaneDuru stating
If you don't like Vlookup and need some VBA code:
1) Example code using Match()
Sub compareListTM()
'define arrays using help function getRange()
Dim arr: arr = getRange(Sheet1.Range("A:A")).Value
Dim data: data = getRange(Sheet1.Range("B:B")).Value
Dim arrFin: arrFin = getRange(Sheet1.Range("D:D")).Value
Dim ret: ret = Application.Match(arrFin, arr, 0) ' Match() items all at once :-)
Dim i As Long
For i = 1 To UBound(ret)
If Not IsError(ret(i, 1)) Then
ret(i, 1) = data(ret(i, 1), 1)
Else
ret(i, 1) = vbNullString
End If
Next i
Sheet1.Range("E2").Resize(UBound(ret), 1).Value = ret
End Sub
If, however you could give VLookUp a try:
2) Example code using worksheetfunction
Sub compareList2()
Dim results
results = WorksheetFunction.VLookup( _
getRange(Sheet1.Range("D:D")), _
getRange(Sheet1.Range("A:B")), _
2, False)
'write results
Sheet1.Range("E2").Resize(UBound(results), 1).Value = results
End Sub
Help function getRange() used in both examples
A way to avoid repeated lastRow, Range definitions in main code.
I don't pretend this function to be perfect in any way, it just meets the necessary requirements for above procedures kept as short as possible.
Function getRange(ColRange As Range, _
Optional ByVal SearchColumn As Variant = 1, _
Optional ByVal StartRow As Long = 2) As Range
'Author : https://stackoverflow.com/users/6460297/t-m
'Purpose: calculate lastrow of a given search column (default: 1st column of ColRange) and
' return ColRange resized to calculated lastrow (considering optional StartRow argument)
'Par. 1 : assumes that ColRange is passed as ENTIRE COLUMN(S) range object, e.g. Range("X:Y")
'Par. 2 : a) a numeric SearchColumn argument refers to the ColRange's column index
' (even outside ColRange, can be negative or higher than columns count in ColRange!)
' b) a literal SearchColumn argument refers to the worksheet column as indicated (e.g. "B")
'Example: getRange(Sheet1.Range("X:Y")) ... calculates lastrow of 1st column in colRange (i.e. in X)
' getRange(Sheet1.Range("X:Y"), "B") ... calculates lastrow of column B in worksheet
'~~~~~~
'1) get columns in ColRange
Dim StartColumn As Long: StartColumn = ColRange.Columns(1).Column
Dim LastColumn As Long: LastColumn = ColRange.Columns(ColRange.Columns.Count).Column
With ColRange.Parent ' i.e. the worksheet
'2) change numeric search column number to letter(s)
If IsNumeric(SearchColumn) Then
If SearchColumn + StartColumn - 1 < 1 Then ' cols left of StartColumn must be at least "A"
SearchColumn = "A"
Else ' get literal column name, e.g. column "D"
SearchColumn = Split((.Columns(SearchColumn + StartColumn - 1).Address(, 0)), ":")(0)
End If
End If
'3) get last row of SearchColumn
Dim lastRow As Long: lastRow = .Range(SearchColumn & .Rows.Count).End(xlUp).Row
If lastRow < StartRow Then lastRow = StartRow ' avoid findings lower than start row
'4) return data range as function result
Set getRange = .Range(.Cells(StartRow, StartColumn), .Cells(lastRow, LastColumn))
End With
End Function

VBA - Multi wildcard filter using array values

Hello VBA Developers,
I am having a hard time solving a multi-wildcard filter for criteria(s) listed in an array. The code stops at "vTst = Doc_ID_Arr(i)", stating vTst = Empty. However, checking Doc_ID_Arr is not empty if you check the debugger.
Sub doc_id()
'Segment 1 ----
'Get the worksheet called "LOB Docs"
Dim sh_1 As Worksheet
Set sh_1 = ThisWorkbook.Worksheets("LOB Docs")
' Declare an array to hold all LOB Doc ID numbers
Dim Doc_ID_Arr As Variant
Dim Doc_ID_Value As String
Dim j As Long
Dim i As Long
With sh_1
lastrow_Header_Config = sh_1.Cells(Rows.count, "A").End(xlUp).Row
' Read LOB DOC ID's from Column Cell A2 to last value in Column A
ReDim Doc_ID_Arr(Application.WorksheetFunction.CountA(sh_1.Range("A2:A" & lastrow_Header_Config)) - 1) As Variant
j = 0
For i = 2 To lastrow_Header_Config
Doc_ID_Value = sh_1.Range("A" & i).Value
If Doc_ID_Value <> "" Then
Doc_ID_Arr(j) = "*" & Doc_ID_Value & "*"
j = j + 1
End If
Next
End With
' ' Debug.Print "Doc_ID_Value"
' For i = LBound(Doc_ID_Arr) To UBound(Doc_ID_Arr)
' Debug.Print Doc_ID_Arr(i)
' Next i
'Segment 2 ----
Dim sh_2 As Worksheet 'Data Sheet
Dim sh_3 As Worksheet 'Output Sheet
Set sh_2 = ThisWorkbook.Worksheets("GDL db") 'Data Sheet
Set sh_3 = ThisWorkbook.Worksheets("Seed Template Output")
Dim Dic As Object
Dim eleData As Variant
Dim eleCrit As Variant
Dim ArrData As Variant
Dim vTst As Variant
Set Dic = CreateObject("Scripting.Dictionary")
Dim x As Long
For x = LBound(Doc_ID_Arr) To UBound(Doc_ID_Arr)
vTst = Doc_ID_Arr(i)
Next x
With sh_2
.AutoFilterMode = False
ArrData = .Range("A1:A" & .Cells(.Rows.count, "A").End(xlUp).Row)
For Each eleCrit In vTst
For Each eleData In ArrData
If eleData Like eleCrit Then _
Dic(eleData) = vbNullString
Next
Next
.Columns("A:A").AutoFilter Field:=1, Criteria1:=Dic.Keys, Operator:=xlFilterValues
sh_2.UsedRange.Copy sh_3.Range("A1")
End With
End Sub
I am trying to filter sh_2, Column A for each value(individual) or all values(en masse) that is placed in the Doc_ID_Arr created in Segment 1. The target is to place each filter output for each ID onto sh_3, without overwriting previous placed values/rows.
Using your previously-posted sample workbook this works for me:
Sub document_link_extract()
'Define data source
Dim GDL_Data As Worksheet 'Datasheet holding Docs links
Dim LOB_Doc As Worksheet 'Docs to filter for
Dim Doc_Output_sh As Worksheet 'Seed Template - curated document list
Dim Doc_ID_List() As String, v, rngIds As Range
Dim arrVals, arrSearch, dict, rwV As Long, rwS As Long, srch
Set GDL_Data = ThisWorkbook.Sheets("Sheet2") 'DataSheet
Set LOB_Doc = ThisWorkbook.Sheets("Sheet1") 'Filter Criteria Sheet
Set Output_sht = ThisWorkbook.Sheets("Sheet3") 'Output for' Look 1/2 - URL Check & PDF Extract
Output_sht.UsedRange.Clear
'get array of search terms
With LOB_Doc
arrSearch = .Range(.Range("A2"), .Cells(.Rows.Count, 1).End(xlUp)).Value
End With
'get array of data column values
With GDL_Data
arrVals = .Range(.Range("A2"), .Cells(.Rows.Count, 1).End(xlUp)).Value
End With
Set dict = CreateObject("scripting.dictionary")
'loop over each search term
For rwS = 1 To UBound(arrSearch, 1)
srch = "*" & arrSearch(rwS, 1) & "*" '<< search term with wildcards
'loop over each value
For rwV = 1 To UBound(arrVals, 1)
v = arrVals(rwV, 1)
'if value matches search term then add to dictionary
If v Like srch Then dict(v) = True
Next rwV
Next rwS
GDL_Data.AutoFilterMode = False 'if there is any filter, remove it
'filter using the dictionary keys array
GDL_Data.UsedRange.AutoFilter 1, dict.keys, xlFilterValues
GDL_Data.UsedRange.Copy Output_sht.Range("A1")
GDL_Data.AutoFilterMode = False
End Sub

Remove rows from a 2d array if value in column is empty

I have a large table of lab measurement logs, which I work with using arrays.
(Im a chemist, a lab technician and Ive started to learn VBA only last week, please bear with me.)
Im trying to figure out, how to load the table into an array and then remove rows with an empty value in the 5th column so that I can "export" the table without blanks in the 5th column via an array into a different sheet.
I first tested this with some code I found for a 1D array, where I would make 2 arrays, one placeholder array which Id loop through adding only non-blanks to a second array.
For Counter = LBound(TestArr) To UBound(TestArr)
If TestArr(Counter, 1) <> "" Then
NoBlankSize = NoBlankSize + 1
NoBlanksArr(UBound(NoBlanksArr)) = TestArr(Counter, 1)
ReDim Preserve NoBlanksArr(0 To UBound(NoBlanksArr) + 1)
End If
Next Counter
It works in 1D, but I cant seem to get it two work with 2 dimensions.
Heres the array Im using for reading and outputting the data
Sub ArrayTest()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim TestArray() As Variant
Dim Dimension1 As Long, Dimension2 As Long
Sheets("Tracker").Activate
Dimension1 = Range("A3", Range("A2").End(xlDown)).Cells.Count - 1
Dimension2 = Range("A2", Range("A2").End(xlToRight)).Cells.Count - 1
ReDim TestArray(0 To Dimension1, 0 To Dimension2)
'load into array
For Dimension1 = LBound(TestArray, 1) To UBound(TestArray, 1)
For Dimension2 = LBound(TestArray, 2) To UBound(TestArray, 2)
TestArray(Dimension1, Dimension2) = Range("A4").Offset(Dimension1, Dimension2).Value
Next Dimension2
Next Dimension1
Sheets("Output").Activate
ActiveSheet.Range("A2").Select
'read from array
For Dimension1 = LBound(TestArray, 1) To UBound(TestArray, 1)
For Dimension2 = LBound(TestArray, 2) To UBound(TestArray, 2)
ActiveCell.Offset(Dimension1, Dimension2).Value = TestArray(Dimension1, Dimension2)
Next Dimension2
Next Dimension1
Erase TestArray
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Thank you for any help in advance.
The Redim Preserve statement does not work for two-dimensional arrays if you want to change the number of records (rows).
You could load the range into an array, and then when you want to export the array to another range, loop through that array while skipping blank records.
An example:
Option Explicit
Sub ArrayTest()
Dim wb As Workbook, wsInput As Worksheet, wsOutput As Worksheet
Dim myArr As Variant
Dim i As Long, k As Long, LRow As Long
Set wb = ThisWorkbook
Set wsInput = wb.Sheets("Tracker")
Set wsOutput = wb.Sheets("Output")
LRow = wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).Row + 1
'Load a range into the array (example range)
myArr = wsInput.Range("A1:Z100")
'Fill another range with the array
For i = LBound(myArr) To UBound(myArr)
'Check if the first field of the current record is empty
If Not Len(myArr(i, 1)) = 0 Then
'Loop through the record and fill the row
For k = LBound(myArr, 2) To UBound(myArr, 2)
wsOutput.Cells(LRow, k) = myArr(i, k)
Next k
LRow = LRow + 1
End If
Next i
End Sub
From your code, it appears you want to
test a column of data on a worksheet to see if there are blanks.
if there are blanks in the particular column, exclude that row
copy the data with the excluded rows to a new area
You can probably do that easier (and quicker) with a filter: code below checking for blanks in column2
Option Explicit
Sub removeCol2BlankRows()
Dim wsSrc As Worksheet, wsRes As Worksheet
Dim rSrc As Range, rRes As Range
Set wsSrc = ThisWorkbook.Worksheets("sheet1")
Set rSrc = wsSrc.Cells(1, 1).CurrentRegion 'many ways to do this
Set wsRes = ThisWorkbook.Worksheets("sheet1")
Set rRes = wsRes.Cells(1, 10)
If wsSrc.AutoFilterMode = True Then wsSrc.AutoFilterMode = False
rSrc.AutoFilter field:=2, Criteria1:="<>"
rSrc.SpecialCells(xlCellTypeVisible).Copy rRes
wsRes.AutoFilterMode = False
End Sub
If you really just want to filter the VBA arrays in code, I'd store the non-blank rows in a dictionary, and then write it back to the new array:
Option Explicit
Sub removeCol2BlankRows()
Dim testArr As Variant
Dim noBlanksArr As Variant
Dim myDict As Object
Dim I As Long, J As Long, V
Dim rwData(1 To 4) As Variant
With ThisWorkbook.Worksheets("sheet1")
testArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=4)
End With
Set myDict = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(testArr, 1)
If testArr(I, 2) <> "" Then
For J = 1 To UBound(testArr, 2)
rwData(J) = testArr(I, J)
Next J
myDict.Add Key:=I, Item:=rwData
End If
Next I
ReDim noBlanksArr(1 To myDict.Count, 1 To 4)
I = 0
For Each V In myDict.keys
I = I + 1
For J = 1 To 4
noBlanksArr(I, J) = myDict(V)(J)
Next J
Next V
End Sub

Type Mismatch using LOOP/IFERROR/INDEX/MATCH

What I am trying to do is looping through all rows and columns to find the quantity of a part inside a machine. This is searched for based on the article number and the Equipment/machine type. As in this screenshot:
My problem is that the way I have it running now is VERY slow. In the screenshot above is only a small portion of the cells. They go down to +-500 equalling roughly 22500 times the formula:
=ifERROR(INDEX(Datasheet!$B$1:$E$100;MATCH(1;(Datasheet!$D:$D=C$1)*(Datasheet!$B:$B=$AY15);0);4);"")
I want to speed it up using VBA by just giving my static values in all cells.
I have a large part done which I will display below.
The search values (datasheet)
I have it almost complete (I can feel it!) but it keeps returning me the type 13 Type mismatch error. I have found MANY MANY threads on stack overflow and the internet but these fixes do not fix it for myself.
My code:
'set all sheets
'----------------------------------------
Dim Isht As Worksheet
Dim Esht As Worksheet
Dim Dsht As Worksheet
Dim Gsht As Worksheet
Set Isht = ThisWorkbook.Worksheets("Instructionsheet")
Set Esht = ThisWorkbook.Worksheets("Exportsheet")
Set Dsht = ThisWorkbook.Worksheets("Datasheet")
Set Gsht = ThisWorkbook.Worksheets("Gathersheet")
'----------------------------------------
Dim EshtLR As Long
Dim EshtLC As Long
Dim DshtLC As Long
Dim DshtLR As Long
Dim OutputRange As Range
Dim SearchRange As Range
Dim MachineMatchCOL As Range
Dim ArticleMatchCOL As Range
Dim MachineType As String
Dim ArticleNumber As String
Dim StartRow As Long
Dim StartCol As Long
StartCol = Dsht.Range("P10").Value
StartRow = Dsht.Range("P11").Value
'Determine Last column in export sheet.
EshtLC = Esht.Cells(14, Columns.count).End(xlToLeft).Column
'Determine Last row in data sheet.
DshtLR = Dsht.Cells(Rows.count, 1).End(xlUp).Row
'Determine Last row in export sheet.
EshtLR = Esht.Cells(Rows.count, 1).End(xlUp).Row
Set OutputRange = Esht.Range(Esht.Cells(StartRow, 3), Esht.Cells(EshtLR, EshtLC - 9))
Set SearchRange = Dsht.Range(Dsht.Cells(1, 2), Dsht.Cells(DshtLR, 5))
Set MachineMatchCOL = Dsht.Range(Dsht.Cells(1, 4), Dsht.Cells(DshtLR, 4))
Set ArticleMatchCOL = Dsht.Range(Dsht.Cells(1, 2), Dsht.Cells(DshtLR, 2))
'=IFERROR(INDEX(Datasheet!$B$1:$E$100;Match(1;(Datasheet!$D:$D=C$1)*(Datasheet!$B:$B=$AY15);0);4);"")
'Datasheet!$B$1:$E$100 = SearchRange
'Datasheet!$D:$D = MachineMatchCOL
'Datasheet!$B:$B = ArticleMatchCOL
'C$1 = MatchineType
'$AY15 = ArticleNumber
j = StartRow
i = StartCol
For Each Row In OutputRange
For Each Column In OutputRange
MachineType = Esht.Range(Esht.Cells(1, i), Esht.Cells(1, i)).Value
ArticleNumber = Esht.Range(Cells(j, EshtLC - 5), Cells(j, EshtLC - 5)).Value
Esht.Cells(j, i).Value = Application.WorksheetFunction _
.IfError(Application.WorksheetFunction _
.Index(SearchRange, Application.WorksheetFunction _
.Match(1, (MachineMatchCOL = MachineType) * (ArticleMatchCOL = ArticleNumber), 0), 4), "")
i = i + 1
Next Column
j = j + 1
Next Row
It has something to do with the fact that a range cannot equal a value but I have tried for a long time and cannot figure it out.
Also note that the loop probably does not work but that is for a next problem to deal with :-).
I do not expect you to fully create everything but, again, a friendly push is also greatly appreciated.
UPDATE: The line that arises error is:
Esht.Cells(j, i).Value = Application.WorksheetFunction _
.IfError(Application.WorksheetFunction _
.Index(SearchRange, Application.WorksheetFunction _
.Match(1, (MachineMatchCOL = MachineType) * (ArticleMatchCOL = ArticleNumber), 0), 4), "")
Build a dictionary of the Datasheet values using columns B & D joined as the key and column E as the item. This will provide virtually instantaneous 'two-column' lookup for the C15:AU29 table on the Exportsheet worksheet.
Option Explicit
Sub PopulateQIMs()
Dim i As Long, j As Long, ds As Object
Dim arr As Variant, typ As Variant, art As Variant, k As Variant
Set ds = CreateObject("scripting.dictionary")
'populate a dictionary
With Worksheets("datasheet")
'collect values from ws into array
arr = .Range(.Cells(3, "B"), .Cells(.Rows.Count, "E").End(xlUp)).Value2
'cycle through array and build dictionary
For i = LBound(arr, 1) To UBound(arr, 1)
'shorthand overwrite method of creating dictionary entries
'key as join(column B & column D), item as column E
ds.Item(Join(Array(arr(i, 1), arr(i, 3)), Chr(0))) = arr(i, 4)
Next i
End With
With Worksheets("exportsheet")
'collect exportsheet 'Type' into array
'typ = .Range(.Cells(1, "C"), .Cells(1, "AU")).Value2
typ = .Range(.Cells(1, "C"), .Cells(1, "C").End(xlToRight)).Value2
'collect exportsheet 'Article Number' into array
'art = .Range(.Cells(15, "AY"), .Cells(29, "AY")).Value2
art = .Range(.Cells(15, "AY"), .Cells(15, "AY").End(xlDown)).Value2
'create array to hold C15:AU29 values
'ReDim arr(1 To 15, 1 To 45)
ReDim arr(LBound(art, 1) To UBound(art, 1), _
LBound(typ, 2) To UBound(typ, 2))
'cycle through Type and Article Numbers and populate array from dictionary
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr, 2) To UBound(arr, 2)
'build a key for lookup
k = Join(Array(art(i, 1), typ(1, j)), Chr(0))
'is it found ...?
If ds.exists(k) Then
'put 'Quantity In Machine' into array
arr(i, j) = ds.Item(k)
End If
Next j
Next i
'put array values into Exportsheet
.Cells(15, "C").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub
Not sure this exactly meets your needs, nor being the most elegant solution - and running out of time to make this more nicer...
It might not work for you straight out of the box, but i hope it gives you an idea on how to better aproach this.
Sub test()
'set all sheets
'----------------------------------------
Dim Isht As Worksheet
Dim Esht As Worksheet
Dim Dsht As Worksheet
Dim Gsht As Worksheet
Set Isht = ThisWorkbook.Worksheets("Instructionsheet")
Set Esht = ThisWorkbook.Worksheets("Exportsheet")
Set Dsht = ThisWorkbook.Worksheets("Datasheet")
Set Gsht = ThisWorkbook.Worksheets("Gathersheet")
'----------------------------------------
Dim EshtLR As Long
Dim EshtLC As Long
Dim DshtLC As Long
Dim DshtLR As Long
Dim OutputRange As Range
Dim SearchRange As Range
Dim MachineMatchCOL As Range
Dim ArticleMatchCOL As Range
Dim MachineType As String
Dim ArticleNumber As String
Dim StartRow As Long
Dim StartCol As Long
StartCol = Dsht.Range("P10").Value
StartRow = Dsht.Range("P11").Value
'Determine Last column in export sheet.
EshtLC = Esht.Cells(14, Columns.Count).End(xlToLeft).Column
'Determine Last row in data sheet.
DshtLR = Dsht.Cells(Rows.Count, 1).End(xlUp).row
'Determine Last row in export sheet.
EshtLR = Esht.Cells(Rows.Count, 1).End(xlUp).row
'Declare and allocate your ranges to arrays
Dim arrOutput As Variant, arrSearch As Variant
arrOutput = Esht.Range(Esht.Cells(1, 3), Esht.Cells(EshtLR, EshtLC)) 'Not sure what last column is here, but i will make a presumption below that "Article number" is last
arrSearch = Dsht.Range(Dsht.Cells(1, 2), Dsht.Cells(DshtLR, 5))
Dim R As Long, C As Long, X As Long
For R = LBound(arrOutput) To UBound(arrOutput)
For C = LBound(arrOutput, 2) To UBound(arrOutput, 2)
For X = LBound(arrSearch) To UBound(arrSearch)
'If the article number has a match in the search
If arrOutput(R, UBound(arrOutput)) = arrSearch(X, 1) Then 'replace UBound(arrOutput) with the "Article number" column number
'Let's check if the machine number is there as well
If arrOutput(1, C) = arrSearch(X, 3) Then
'both found at the same row, return the value from that row
arrOutput(R, C) = arrSearch(X, 4)
End If
End If
Next X
Next C
Next R
End Sub
PS: You still need to write the values back to the sheet from the array, which you can either do directly range = array or through a loop, depending on your needs.
I`ll try to complete the answer later when i get more time (at work!).

VBA: Use Dictionary instead vlookup function

I'm using the vlookup function in my vba code, but it's taking too much time to run when I have more then 100k rows of data:
Sub getType()
Application.ScreenUpdating = False
Application.Calculation = xlManual
On Error Resume Next
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim Row As Long
Dim Clm As Long
Set ws = Sheets("P")
LastRow1 = ws.Cells(Rows.Count, "A").End(xlUp).Row
Table1 = Sheet2.Range("A2:A" & LastRow1)
Set ws = Sheets("CRI")
LastRow2 = ws.Cells(Rows.Count, "A").End(xlUp).Row
Table2 = CRI.Range("A2:D" & LastRow2)
Row = Sheet2.Range("J2").Row
Clm = Sheet2.Range("J2").Column
For Each cl In Table1
Sheet2.Cells(Row, Clm).Value = Application.WorksheetFunction.VLookup(cl, Table2, 4, False)
Row = Row + 1
Next cl
Calculate
Reading some topics here I checked that it's possible to speed up by using dictionary, but I didn't understand the concepts correctly to implement the solution on my code.
Also, there is no duplicate data on table2, but table1 contains duplicate values.
Could anyone please help me convert vlookup to dictionary and if possible reference some videos tutorials so I can learn the concept?
This is good explanation on the use of a dictionary:
https://excelmacromastery.com/vba-dictionary/
Don't forget to add “Microsoft Scripting Runtime” as a reference to your project.
I ran a few tests to check performance. For a million rows of data I had the following results:
VLookup: 27.93 seconds
Dictionary: 20.83 seconds
Dictionary and array: 2.32 seconds
Have you considered using a dictionary and an array to store the values before writing them to the sheet? This link will provide you with some good information:
https://excelmacromastery.com/excel-vba-array/#How_To_Make_Your_Macros_Run_at_Super_Speed
Consider the following (I tried to leave as much of your original code as possible):
Application.ScreenUpdating = False
Application.Calculation = xlManual
On Error GoTo Handler
Dim ws As Worksheet
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim i As Long
Dim Table1 As Range
Dim Table2 As Range
Dim cl As Range
Dim r As Range
Dim targetRange As Range
Dim valuesArray As Variant
Dim dict As New Scripting.Dictionary
Dim timeStart As Double
Dim timeInterval As Double
'start a timer to measure performance
timeStart = Timer()
'Get the column of data to search through
Set ws = Sheets("P")
LastRow1 = ws.Cells(Rows.Count, "A").End(xlUp).Row
Set Table1 = ws.Range("A2:A" & LastRow1)
'Get the table of values to search for
Set ws = Sheets("CRI")
LastRow2 = ws.Cells(Rows.Count, "A").End(xlUp).Row
Set Table2 = ws.Range("A2:D" & LastRow2)
'Add the contents of the table you are searching to the dictionary:
'For each row in the table
For Each r In Table2.Rows
'Add the key and associated value for that key
dict.Add r.Cells(1, 1).Value, r.Cells(1, 4).Value
Next r
'Dimension an array to fit all of your values
ReDim valuesArray(1 To LastRow1, 1 To 1)
'Use i to allocate the data to the array
i = 1
For Each cl In Table1
'Set the value of the array element to the value returned by the dictionary
valuesArray(i, 1) = dict(cl.Value)
i = i + 1
Next cl
'Set a target range to put your values in and make it the right size to fit your array
Set targetRange = Worksheets("Target").Range("J2").Resize(UBound(valuesArray, 1) - 1)
'Put the array in the target range
targetRange = valuesArray
'Check how much time it took
timeInterval = Timer() - timeStart
Debug.Print timeInterval
Application.ScreenUpdating = True
Hope this helps.
Here's some test code to show why I suggested running your VLOOKUP against the range on the worksheet instead of against the array (which is what you got by not using Set Table = ... )
Worksheet formulas like vlookup are optimised for worksheets, not for arrays.
The lookup against the sheet is about 130x faster than the array lookup.
Sub Tester()
Const NUMR As Long = 100000
Dim r As Long, arr, t, m, rng
'Fill some dummy data if not already there
If Sheet1.Range("A1") = "" Then
For r = 1 To NUMR
Sheet1.Cells(r, 1).Resize(1, 4).Value = _
Array(CLng(Rnd * NUMR), "A", "B", r)
Next r
End If
Set rng = Sheet1.Range("A1").CurrentRegion
arr = rng.Value
'Vlookup against array
t = Timer
For r = 1 To 100
m = Application.VLookup(r, arr, 4, False)
Next r
Debug.Print Timer - t '>> 10.28
'Vlookup against worksheet Range
t = Timer
For r = 1 To 100
m = Application.VLookup(r, rng, 4, False)
Next r
Debug.Print Timer - t '>> 0.078
End Sub

Resources