I am looking for some help in creating a new column and filling the row values with the sum four other columns in the row. I have attempted using the code below however I continually receive a type mismatch problem when trying to run it on the row:
results(i) = SForehandRange(i, 1) + SBackhandRange(i, 1) + RForehandRange(i, 1) + RBackhandRange(i, 1)
I'm not sure if this is the exact problem and would be grateful of any assistance.
The code is running on a table that i have already created and the values in it are numbers. Some cells will be blank however I tried filling all cells with values and still received the error.
Sub sumShotsInRally()
'Set rawData sheet as active
Dim sht1 As Worksheet
Set sht1 = Sheets("rawData")
sht1.Activate
'Find the Columns to Add
Dim serverForehandColNum As Integer
serverForehandColNum = ActiveSheet.Rows(1).Find(what:="Serving player forehand", lookat:=xlWhole).Column
Dim serverBackhandColNum As Integer
serverBackhandColNum = ActiveSheet.Rows(1).Find(what:="Serving player backhand", lookat:=xlWhole).Column
Dim returnerForehandColNum As Integer
returnerForehandColNum = ActiveSheet.Rows(1).Find(what:="Returning player forehand", lookat:=xlWhole).Column
Dim returnerBackhandColNum As Integer
returnerBackhandColNum = ActiveSheet.Rows(1).Find(what:="Returning player backhand", lookat:=xlWhole).Column
'Insert new column for the sum total
ActiveSheet.Columns(serverForehandColNum + 1).Insert
' Add New col heading
ActiveSheet.Cells(1, serverForehandColNum + 1).Value = "Rally Count"
Dim rallyCountColNum As Integer
rallyCountColNum = ActiveSheet.Rows(1).Find(what:="Rally Count", lookat:=xlWhole).Column
'Define the range to iterate over
Dim SForehandRange As Range
Dim SBackhandRange As Range
Dim RForehandRange As Range
Dim RBackhandRange As Range
Dim rallyRange As Range
With ActiveSheet
Set SForehandRange = .Range(.Cells(2, serverForehandColNum), .Cells(.UsedRange.Rows.Count, serverForehandColNum))
Set SBackhandRange = .Range(.Cells(2, serverBackhandColNum), .Cells(.UsedRange.Rows.Count, serverBackhandColNum))
Set RForehandRange = .Range(.Cells(2, returnerForehandColNum), .Cells(.UsedRange.Rows.Count, returnerForehandColNum))
Set RBackhandRange = .Range(.Cells(2, returnerBackhandColNum), .Cells(.UsedRange.Rows.Count, returnerBackhandColNum))
Set rallyRange = .Range(.Cells(2, rallyCountColNum), .Cells(.UsedRange.Rows.Count, rallyCountColNum))
End With
Dim results()
'You redimension the results array to the number of entries in your table
ReDim results(1 To SForehandRange.Rows.Count)
'You loop over your table and sum the values from count and restocked
For i = 1 To SForehandRange.Rows.Count
results(i) = SForehandRange(i, 1) + SBackhandRange(i, 1) + RForehandRange(i, 1) + RBackhandRange(i, 1)
Next i
'You write the array to the range count and delete the values in restocjed
rallyRange = Application.Transpose(results)
End Sub
Related
for clarity, see pics and code
Hi,
Having these data:
Table 1 in "customers" sheet
Table 2 in "cars" sheet
I'm able to get the matching value of each row of "customers" to "cars" in a separate sheet "results".
However, I need to achieve 2 things:
Reporting in column A "results" sheet, the A column value of each respective row (therefore extracting this from the individual sheets of "customers" and "cars").
Having a similar table layout with headers denoting the respective columns of results
Col A= Customer/Inventory
Col B= Car
Col C= Color
Col D= Interior
I have been able to achieve up to this stage (pics) from the attached
Sub GenerateTable()
Dim selectedRows As Range
Set selectedRows = ThisWorkbook.Sheets("customers").Range("B2:D9")
Dim resultSheet As Worksheet
On Error Resume Next
Set resultSheet = ThisWorkbook.Sheets("results")
On Error GoTo 0
If resultSheet Is Nothing Then
Set resultSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
resultSheet.Name = "results"
End If
resultSheet.Cells.Clear
Dim carsSheet As Worksheet
Set carsSheet = ThisWorkbook.Sheets("cars")
Dim carsRange As Range
Set carsRange = carsSheet.Range("B2:D13")
Dim rng As Range
Dim row As Range
Dim found As Range
Dim match As Boolean
Dim lastRow As Long
For Each row In selectedRows.Rows
match = False
For Each rng In carsRange.Rows
If row.Cells(1, 1) = rng.Cells(1, 1) And row.Cells(1, 2) = rng.Cells(1, 2) And row.Cells(1, 3) = rng.Cells(1, 3) Then
If match = False Then
lastRow = resultSheet.Cells(Rows.Count, 1).End(xlUp).row + 1
row.Copy resultSheet.Cells(lastRow, 1)
match = True
End If
rng.Copy resultSheet.Cells(lastRow + 1, 1)
lastRow = lastRow + 1
End If
Next rng
Next row
End Sub
Cars
result:
I am trying to create an array where values come from the first row of a worksheet, then print those values in another sheet.
I tried to read the first row of Sheet2, store each value in the array until I hit an empty cell, then print that array in the first row of Sheet3.
I'm getting a application defined error in the while loop where I am making sure the row is not equal to Null.
Private Sub createFormatSheet()
With Worksheets("Sheet2")
Dim myTags() As Variant
Dim tag As Variant
Dim rw As Range
Dim i As Integer
i = 1
For Each rw In .Rows
While rw(i, 1) <> Null
myTags = Array(rw(i, 1))
i = i + 1
Wend
Next rw
End With
With Worksheets("Sheet3")
i = 1
For Each tag In myTag
.Cells(i, 1).Value = tag
Next tag
End With
End Sub
Here are two approaches:
Using an array (you don't need to loop through the items
Directly using ranges, no array involved
Step through the code using F8 and see what's going on
Private Sub createFormatSheet()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim startRow As Long
Dim endRow As Long
Dim values As Variant
Set sourceSheet = ThisWorkbook.Worksheets("Sheet2")
Set targetSheet = ThisWorkbook.Worksheets("Sheet3")
' Array approach (no need to loop) source = column 1
startRow = 1
endRow = sourceSheet.Cells(startRow, 1).End(xlDown).Row
values = sourceSheet.Range(sourceSheet.Cells(startRow, 1), sourceSheet.Cells(endRow, 1)).Value
' Target = column 1
targetSheet.Cells(startRow, 1).Resize(endRow, 1).Value = values
' Direct range target column 2
targetSheet.Cells(startRow, 2).Resize(endRow, 1).Value = sourceSheet.Range(sourceSheet.Cells(startRow, 1), sourceSheet.Cells(endRow, 1)).Value
End Sub
Let me know if it works
I've got three sheets - main,specimen and output in an excel workbook. The sheet main and speciment contain some information. Some of the information in two sheets are identical but few of them are not. My intention is to paste those information in output which are available in speciment but not in main.
I've tried like [currently it fills in lots of cells producing duplicates]:
Sub getData()
Dim cel As Range, celOne As Range, celTwo As Range
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("main")
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets("specimen")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets("output")
For Each cel In ws.Range("A2:A" & ws.Cells(Rows.Count, 1).End(xlUp).row)
For Each celOne In ws1.Range("A2:A" & ws1.Cells(Rows.Count, 1).End(xlUp).row)
If cel(1, 1) <> celOne(1, 1) Then ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).value = celOne(1, 1)
Next celOne
Next cel
End Sub
main contains:
UNIQUE ID FIRST NAME LAST NAME
A0000477 RICHARD NOEL AARONS
A0001032 DON WILLIAM ABBOTT
A0290191 REINHARDT WESTER CARLSON
A0290284 RICHARD WARREN CARLSON
A0002029 RAYMOND MAX ABEL
A0002864 DARRYL SCOTT ABLING
A0003916 GEORGES YOUSSEF ACCAOUI
specimen contains:
UNIQUE ID FIRST NAME LAST NAME
A0288761 ROBERT HOWARD CARLISLE
A0290284 RICHARD WARREN CARLSON
A0290688 THOMAS A CARLSTROM
A0002029 RAYMOND MAX ABEL
A0002864 DARRYL SCOTT ABLING
output should contain [EXPECTED]:
UNIQUE ID FIRST NAME LAST NAME
A0288761 ROBERT HOWARD CARLISLE
A0290688 THOMAS A CARLSTROM
How can I achieve that?
If you have the latest version of Excel, with the FILTER function and dynamic arrays, you can do this with an Excel formula.
I changed your Main and Specimen data into tables.
On the Output worksheet you can then enter this formula into a single cell:
=FILTER(specTbl,ISNA(MATCH(specTbl[UNIQUE ID],mnTbl[UNIQUE ID],0)))
The remaining fields will autopopulate with the results.
For a VBA solution, I like to use Dictionaries, and VBA arrays for speed.
'set reference to microsoft scripting runtime
' or use late-binding
Option Explicit
Sub findMissing()
Dim wsMain As Worksheet, wsSpec As Worksheet, wsOut As Worksheet
Dim dN As Dictionary, dM As Dictionary
Dim vMain As Variant, vSpec As Variant, vOut As Variant
Dim I As Long, v As Variant
With ThisWorkbook
Set wsMain = .Worksheets("Main")
Set wsSpec = .Worksheets("Specimen")
Set wsOut = .Worksheets("Output")
End With
'Read data into vba arrays for processing speed
With wsMain
vMain = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
End With
With wsSpec
vSpec = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
End With
'add ID to names dictionary
Set dN = New Dictionary
For I = 2 To UBound(vMain, 1)
dN.Add Key:=vMain(I, 1), Item:=I
Next I
'add missing ID's to missing dictionary
Set dM = New Dictionary
For I = 2 To UBound(vSpec, 1)
If Not dN.Exists(vSpec(I, 1)) Then
dM.Add Key:=vSpec(I, 1), Item:=WorksheetFunction.Index(vSpec, I, 0)
End If
Next I
'write results to output array
ReDim vOut(0 To dM.Count, 1 To 3)
vOut(0, 1) = "UNIQUE ID"
vOut(0, 2) = "FIRST NAME"
vOut(0, 3) = "LAST NAME"
I = 0
For Each v In dM.Keys
I = I + 1
vOut(I, 1) = dM(v)(1)
vOut(I, 2) = dM(v)(2)
vOut(I, 3) = dM(v)(3)
Next v
Dim R As Range
With wsOut
Set R = .Cells(1, 1)
Set R = R.Resize(UBound(vOut, 1) + 1, UBound(vOut, 2))
With R
.EntireColumn.Clear
.Value = vOut
.Style = "Output"
.EntireColumn.AutoFit
End With
End With
End Sub
Both show the same result (except the formula solution does not bring over the column headers; but you can do that with a formula =mnTbl[#Headers] in the cell above the original formula above).
Another option is to join the values of each row in each range and store them in arrays.
Then compare arrays and output the unique values.
In this case, your uniques come from evaluating the whole row, and not just the Unique ID.
Please read code's comments and adjust it to fit your needs.
Public Sub OutputUniqueValues()
Dim mainSheet As Worksheet
Dim specimenSheet As Worksheet
Dim outputSheet As Worksheet
Dim mainRange As Range
Dim specimenRange As Range
Dim mainArray As Variant
Dim specimenArray As Variant
Dim mainFirstRow As Long
Dim specimenFirstRow As Long
Dim outputCounter As Long
Set mainSheet = ThisWorkbook.Worksheets("main")
Set specimenSheet = ThisWorkbook.Worksheets("specimen")
Set outputSheet = ThisWorkbook.Worksheets("output")
' Row at which the output range will be printed (not including headers)
outputCounter = 2
' Process main data ------------------------------------
' Row at which the range to be evaluated begins
mainFirstRow = 2
' Turn range rows into array items
mainArray = ProcessRangeData(mainSheet, mainFirstRow)
' Process specimen data ------------------------------------
' Row at which the range to be evaluated begins
specimenFirstRow = 2
' Turn range rows into array items
specimenArray = ProcessRangeData(specimenSheet, specimenFirstRow)
' Look for unique values and output results in sheet
OutputUniquesFromArrays outputSheet, outputCounter, mainArray, specimenArray
End Sub
Private Function ProcessRangeData(ByVal dataSheet As Worksheet, ByVal firstRow As Long) As Variant
Dim dataRange As Range
Dim evalRowRange As Range
Dim lastRow As Long
Dim counter As Long
Dim dataArray As Variant
' Get last row in sheet (column 1 = column A)
lastRow = dataSheet.Cells(dataSheet.Rows.Count, 1).End(xlUp).Row
' Set the range of specimen sheet
Set dataRange = dataSheet.Range("A" & firstRow & ":C" & lastRow)
' Redimension the array to the number of rows in range
ReDim dataArray(dataRange.Rows.Count)
counter = 0
' Join each row values so it's easier to compare them later and add them to an array
For Each evalRowRange In dataRange.Rows
' Use Trim function if you want to omit the first and last characters if they are spaces
dataArray(counter) = Trim(evalRowRange.Cells(1).Value) & "|" & Trim(evalRowRange.Cells(2).Value) & "|" & Trim(evalRowRange.Cells(3).Value)
counter = counter + 1
Next evalRowRange
ProcessRangeData = dataArray
End Function
Private Sub OutputUniquesFromArrays(ByVal outputSheet As Worksheet, ByVal outputCounter As Long, ByVal mainArray As Variant, ByVal specimenArray As Variant)
Dim specimenFound As Boolean
Dim specimenCounter As Long
Dim mainCounter As Long
' Look for unique values ------------------------------------
For specimenCounter = 0 To UBound(specimenArray)
specimenFound = False
' Check if value in specimen array exists in main array
For mainCounter = 0 To UBound(mainArray)
If specimenArray(specimenCounter) = mainArray(mainCounter) Then specimenFound = True
Next mainCounter
If specimenFound = False Then
' Write values to output sheet
outputSheet.Range("A" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(0)
outputSheet.Range("B" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(1)
outputSheet.Range("C" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(2)
outputCounter = outputCounter + 1
End If
Next specimenCounter
End Sub
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!).
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