I have a column with certain values which are also the headers for some columns. I want to check where the column values match and paste the value from the first column into the column with the same column name. I have around 1200 values in the first column. I want to loop through those values and paste the matching values in the corresponding row.
[![Data][1]][1]
Here is my sheet with my data that I want to work on. How I want my final sheet to look like is as follows:
Weeks | W1 | W2 | W3 | W4 | W5 | W6
W1 W1
W3 W3
Any help for the same would be highly appreciated.
Sub Weeks()
Application.ScreenUpdating = False
Dim i As Long, j As Long, Mas As Worksheet
Set Mas = Sheets("Master Sheet")
For i = 5 To 1200
If Mas.Range("B" & i) <> "" Then
If Mas.Range("AO" & i) = "Missing week" Then
Mas.Range("AV" & i) = ""
Mas.Range("AW" & i) = ""
Mas.Range("AX" & i) = ""
Mas.Range("AY" & i) = ""
Mas.Range("AZ" & i) = ""
Mas.Range("BA" & i) = ""
Else
For j = 5 To 1200
If Mas.Range("AO" & i) = "W1" Then
Mas.Range("AV" & j) = "W1"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W2" Then
Mas.Range("AW" & j) = "W2"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W3" Then
Mas.Range("AX" & j) = "W3"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W4" Then
Mas.Range("AY" & j) = "W4"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W5" Then
Mas.Range("AZ" & j) = "W5"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W6" Then
Mas.Range("BA" & j) = "W6"
GoTo Nexti
End If
Next j
End If
End If
Nexti:
Next i
End Sub
This is the code I tried so far but it does not show any output.
This is how you use the dictionary to achieve your goal:
Option Explicit
Sub Weeks()
Dim Mas As Worksheet: Set Mas = ThisWorkbook.Sheets("Master Sheet")
With Mas
'Calculate thelast row
Dim i As Long
Dim LastRow As Long: LastRow .Cells(.Rows.Count, "AO").End(xlUp).Row
'insert your data into an array
Dim arr As Variant: arr = .Range("AO5:BA" & LastRow).Value
'Generate a dictionary with the headers
'this needs the library Microsoft Scripting Runtime under Tools->References
Dim Headers As Dictionary: Set Headers = LoadHeaders(.Range("AO4:BA4").Value)
'Now loop through the array
For i = 1 To UBound(arr)
If Headers.Exists(arr(i, 1)) Then arr(i, Headers(arr(i, 1))) = arr(i, 1)
arr(i, 1) = vbNullString
Next i
.Range("AO5:BA" & LastRow).Value = arr
End With
End Sub
Private Function LoadHeaders(arr As Variant) As Dictionary
Set LoadHeaders = New Dictionary
Dim i As Long
For i = 1 To UBound(arr, 2)
LoadHeaders.Add arr(1, i), i
Next i
End Function
You won't even need the Application.ScreenUpdating because it does only one operation in Excel, will take a second or two to end this procedure.
Place this code in a module and link it to a button on the sheet.
'data
Cells.Clear
wks = Array("W1", "W2", "W3", "W4", "W5", "W6", "Missing week")
For i = 1 To 30
Cells(i, 2) = wks(Int(Rnd * 7))
Next i
'code
Set weeks = [b:b]
For Each wk In weeks
If Len(wk) = 2 Then Cells(wk.Row, Right(wk, 1) + 2) = wk
Next wk
weeks contains the column that has the list of column headings. The For..Each statement loops through each entry in this list.
Then it checks each entries string length. If it is length 2, it assumes the entry is valid (i.e of the form 'Wx' with x between 1 and 6), and then uses the inbuilt Right function to find the value of x, and then adds the appropriate entry into the appropriate column.
Related
The following code successfully executes for small data sets:
Option Explicit
Option Base 1
Sub Left()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim ws1, _
ws2 As Worksheet, _
wb As Workbook
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets("Adj")
Set ws2 = wb.Worksheets("Deleted")
Dim a, _
b, _
i, _
j, _
k As Long
a = 957
b = 290150
Dim Item1, _
Item2, _
Arr() As Variant
With ws2
For i = 2 To a
.Cells(i, 6) = Left(.Cells(i, 1), 11)
.Cells(i, 7) = Right(.Cells(i, 1), 4)
Next i
End With
With ws1
For j = 2 To b
ReDim Preserve Arr(j - 1)
Item1 = Chr(34) & .Cells(j, 7) & Chr(34)
Item2 = Chr(34) & .Cells(j, 9) & Chr(34)
On Error Resume Next
k = Evaluate("=MATCH(1,('Deleted'!F:F = " & Item1 & ")*('Deleted'!G:G = " & Item2 & "),0)")
If Err.Number = 13 Then
Arr(j - 1) = ""
Else: Arr(j - 1) = k
End If
On Error GoTo 0
Next j
.Range(.Cells(2, 15), .Cells(b, 15)) = WorksheetFunction.Transpose(Arr())
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
However, for large data sets - such as 290,150 rows - the macro spins its wheels. It's known that Evaluate is expensive to run and I have tried running for sample sizes of 30 (success) and 1,000 (unsuccessful) and debugged carefully. Obviously in-cell array formulation drag-and-drop is not a practical alternative. So, the problem reduces to resolving endless spinning for the given multiple criteria match function required.
How do I bypass this constraint?
Try this approach using a dictionary as a lookup:
Sub Left()
Dim wsAdj As Worksheet, wsDel As Worksheet, wb As Workbook
Dim lrDel As Long, lrAdj As Long, r As Long
Dim dict, t, arr, arrG, arrI, arrRes, k
Set wb = ThisWorkbook
Set wsAdj = wb.Worksheets("Adj")
Set wsDel = wb.Worksheets("Deleted")
lrAdj = 290150
lrDel = 957
t = Timer
'load a dictionary with lookup values constructed from wsDel ColA
Set dict = CreateObject("scripting.dictionary")
arr = wsDel.Range("A2:A" & lrDel).Value
For r = 1 To UBound(arr, 1)
k = Left(arr(r, 1), 11) & Chr(0) & Right(arr(r, 1), 4)
dict(k) = r + 1 '+1 to adjust for starting at row 2
Next r
arrG = wsAdj.Range("G2:G" & lrAdj).Value 'get the match columns as arrays
arrI = wsAdj.Range("I2:I" & lrAdj).Value
ReDim arrRes(1 To UBound(arrG, 1), 1 To 1) 'resize the "result" array
'loop the values from wsAdj
For r = 1 To UBound(arrG, 1)
k = arrG(r, 1) & Chr(0) & arrI(r, 1) 'build the "key"
If dict.exists(k) Then
arrRes(r, 1) = dict(k) 'get the matched row
End If
Next r
wsAdj.Cells(2, 15).Resize(UBound(arrRes, 1), 1).Value = arrRes 'put the array on the sheet
Debug.Print "done", Timer - t ' <1 sec
End Sub
Stating Ranges instead of Columns and removing ReDim on loop helped.
i tried using dictionary but it only counts the repetition but i want to know the exact frequency of all datas in a column
what ive used is
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
End If
Next x
items.RemoveAll
End Sub
and this gives me
[1: https://i.stack.imgur.com/Mhp5g.png][1]
but what i need is
[4: https://i.stack.imgur.com/UYOFu.png][4]
I think this is what you were after. Please try it.
Sub CountThings()
Dim Ws As Worksheet
Dim Items As Object ' Scripting.Dictionary
Dim Arr As Variant ' values in column B
Dim R As Long ' loop couner: Rows
Dim Key As Variant ' loop counter: dictionary keys
Set Items = CreateObject("Scripting.Dictionary")
Set Ws = ActiveSheet ' better: define tab by name
With Ws
' reading from the sheet is slow
' therefore read all items at once
Arr = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value
' this is a 1-based 2-D array, like Arr([Rows], [Column])
' where column is always 1 because there's only 1 column
End With
For R = 1 To UBound(Arr)
If Items.Exists(Trim(Arr(R, 1))) Then
Items(Trim(Arr(R, 1))) = Items(Trim(Arr(R, 1))) + 1
Else
Items.Add Trim(Arr(R, 1)), 1
End If
Next R
ReDim Arr(1 To Items.Count, 1 To 2)
R = 0
For Each Key In Items.keys
R = R + 1
Arr(R, 1) = Key
Arr(R, 2) = Items(Key)
Next Key
' specify the top left cell of the target range
Ws.Cells(2, "C").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
Set Items = Nothing
End Sub
You need not Trim the Keys if you are sure that there can't be any stray leading or trailing blanks.
Your second picture doesn't need VBA. It can be produce by this formula, entered in C2 and copied down.
=COUNTIF($B$2:$B$13,$B2)
In fact, you can even do the job of my above code without VBA. Enter this formula in G2 of your sheet as an array formula (confirmed with CTL + SHIFT + ENTER if you don't have Excel 365), and the other one in H. Then copy both formulas down.
[G2] =IFERROR(INDEX($B$2:$B$13, MATCH(0, COUNTIF($G$1:G1, $B$2:$B$13), 0)), "")
[H2] =IF($G2<>"",COUNTIF($B$2:$B$13,$G2),"")
You need to assign values to column C after you have finished counting and therefore, need another loop:
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.Count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
End If
Next x
For x = 2 To lastrow
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Next x
items.RemoveAll
Set items = Nothing
End Sub
A simpler way to achieve what you want is to let excel do the counting for you like this:
Sub countThings2()
Dim sDataAddress As String
With ActiveSheet
sDataAddress = "$B$2:$B$" & .Cells(Rows.Count, "B").End(xlUp).Row
With .Range(sDataAddress).Offset(0, 1)
.Formula2 = "=COUNTIF(" & sDataAddress & ",B2)"
.Value = .Value
End With
End With
End Sub
i use table and 2 functions. not simple way but works :)
Sub Fx()
Dim str_Tab() As String, str_Text As String, str_Result As String
Dim int_Counter As Integer, int_TabItemCounter As Integer, int_LastRow As Integer
Dim rng_WorkRange As Range
int_LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set rng_WorkRange = ActiveSheet.Range("A1:A" & int_LastRow)
For i = 1 To int_LastRow
str_Text = ActiveSheet.Range("A" & i)
If i > 1 Then
str_Result = IsInArray(str_Text, str_Tab)
If str_Result = -1 Then
int_TabItemCounter = UBound(str_Tab) - LBound(str_Tab)
ReDim str_Tab(int_TabItemCounter)
str_Tab(int_TabItemCounter) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
Else
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If str_Result = -1
Else ' If i > 1
ReDim str_Tab(i)
str_Tab(i) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If i > 1
Next i
End Sub
function to check is text in table
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
Dim i As Long
' default return value if value not found in array
IsInArray = -1
For i = LBound(arr) To UBound(arr)
If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
IsInArray = i
Exit For
End If
Next i
End Function
function to count item in range
Function CountThisItem(CountingRange As Range, a As String) As Integer
Dim rng_FindRange As Range
Dim LA As String
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole)
If Not rng_FindRange Is Nothing Then
LA = rng_FindRange.Address
CountThisItem = 1
Do
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole, after:=rng_FindRange)
If Not rng_FindRange Is Nothing And rng_FindRange.Address <> LA Then CountThisItem = CountThisItem + 1
Loop While rng_FindRange.Address <> LA
Else
CountThisItem = 0
End If
End Function
I am trying to remove rows from a spreadsheet in VBA if the sum total of value exceeds a specific amount.
For example, if I have the following data, names in A1 down and values in A2 down:
I would like to remove all rows where the total sum of the value in row A does not reach 10 or above in row B, this would leave the following results:
Thomas = 18 and John = 15 so all rows with Thomas and John are kept.
All other rows would be deleted.
Please note that I will always know that the data is in row A and B but I do not know how many rows there will be and need to execute until the first blank cell.
It worked. You can see this here:
Sub run()
Dim rowIndex, countSameRow, sumSameRow As Integer
sumSameRow = Cells(1, 2)
rowIndex = 2
countSameRow = 1
While IsEmpty(Cells(rowIndex, 1)) = False
If (Cells(rowIndex, 1) = Cells(rowIndex - 1, 1)) Then
sumSameRow = sumSameRow + Cells(rowIndex, 2)
countSameRow = countSameRow + 1
Else
If (sumSameRow < 10) Then
Rows(rowIndex - 1 & ":" & rowIndex - countSameRow).Delete
rowIndex = rowIndex - countSameRow
End If
countSameRow = 1
sumSameRow = Cells(rowIndex, 2)
End If
If IsEmpty(Cells(rowIndex + 1, 1)) Then
If (sumSameRow < 10) Then
Rows(rowIndex & ":" & rowIndex - countSameRow + 1).Delete
End If
End If
rowIndex = rowIndex + 1
Wend
End Sub
Totally agree you should write your own code first, but I couldn't help but write some starting code for you. See if the below fits your purpose:
Sub Test()
Dim lr As Long, x As Long
Dim arr As Variant, rng As Range
Dim dict1 As Object: Set dict1 = CreateObject("Scripting.Dictionary")
Dim dict2 As Object: Set dict2 = CreateObject("Scripting.Dictionary")
With Sheet1 'Change according to your sheets CodeName
'Get all of your data form A:B in memory (array)
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("A1:B" & lr)
'Step through the array and fill up our two dictionaries
For x = LBound(arr) To UBound(arr)
If dict1(arr(x, 1)) <> "" Then
dict1(arr(x, 1)) = Join(Array(dict1(arr(x, 1)), x & ":" & x), ",")
Else
dict1(arr(x, 1)) = x & ":" & x
End If
dict2(arr(x, 1)) = dict2(arr(x, 1)) + arr(x, 2)
Next x
'Step through our second dictionary and check if value < 10
For Each Key In dict2.keys
If dict2(Key) < 10 Then
If Not rng Is Nothing Then
Set rng = Union(rng, .Range(dict1(Key)))
Else
Set rng = .Range(dict1(Key))
End If
End If
Next Key
'If any where below 10, this Range object has been filled, so delete it.
If Not rng Is Nothing Then
rng.Delete
End If
End With
End Sub
Here is another method that uses Autofilter and SUMIF to delete the lines.
This assumes there is a header row, if not then add a row first.
It adds a sumif in column C and filters all that is less than 10, then deletes them.
Then removes column C again.
Sub filter()
Range("C1").Value = "Sum"
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("C2:C" & Lastrow).Formula = "=sumif(A:A,A2,B:B)"
Range("A2").AutoFilter ' add a filter to table
ActiveSheet.Range("$A$1:$C$" & Lastrow).AutoFilter Field:=3, Criteria1:="<10", Operator:=xlAnd ' filter all below 10
ActiveSheet.Range("A2:C" & Lastrow).SpecialCells(xlCellTypeVisible).EntireRow.Delete ' delete them
Range("A1").AutoFilter ' remove filter again
Columns("C:C").EntireColumn.Delete ' remove column C
End Sub
I search any text within Worksheet2 and display the results in ListBox1.
Private Sub SearchButton_Click()
'ListBox1.Clear
ListBox1.RowSource = ""
ListBox1.ColumnHeads = False
'listbox column headers
Me.ListBox1.AddItem
For A = 1 To 8
Me.ListBox1.List(0, A - 1) = Sheet2.Cells(1, A)
Next A
Me.ListBox1.Selected(0) = True
'Populating listbox from search
Dim i As Long
For i = 2 To Sheet2.Range("A100000").End(xlUp).Offset(1, 0).Row
For j = 1 To 8
H = Application.WorksheetFunction.CountIf(Sheet2.Range("A" & i, "H" & i), Sheet2.Cells(i, j))
If H = 1 And LCase(Sheet2.Cells(i, j)) = LCase(Me.TextBox2) Or H = 1 And _
Sheet2.Cells(i, j) = Val(Me.TextBox2) Then
Me.ListBox1.AddItem
For X = 1 To 8
Me.ListBox1.List(ListBox1.ListCount - 1, X - 1) = Sheet2.Cells(i, X)
Next X
End If
Next j
Next i
End Sub
I want to search multiple worksheets instead but don't know how to achieve this without changing the code completely.
You're going to have to change the reference to Sheet2 if you want to look at multiple sheets. There's no way around that. But, it will make your code more flexible. Start by doing this:
Private Sub SearchButton_Click()
'ListBox1.Clear
ListBox1.RowSource = ""
ListBox1.ColumnHeads = False
'listbox column headers
Me.ListBox1.AddItem
For A = 1 To 8
Me.ListBox1.List(0, A - 1) = Sheet2.Cells(1, A)
Next A
Me.ListBox1.Selected(0) = True
Dim ws As Worksheet 'This is the new line of code where you define your worksheet
Set ws = ActiveWorkbook.Sheet2 'Replace all references below to Sheet2 with this
'Populating listbox from search
Dim i As Long
For i = 2 To ws.Range("A100000").End(xlUp).Offset(1, 0).Row
For j = 1 To 8
H = Application.WorksheetFunction.CountIf(ws.Range("A" & i, "H" & i), Sheet2.Cells(i, j))
If H = 1 And LCase(Sheet2.Cells(i, j)) = LCase(Me.TextBox2) Or H = 1 And _
ws.Cells(i, j) = Val(Me.TextBox2) Then
Me.ListBox1.AddItem
For X = 1 To 8
Me.ListBox1.List(ListBox1.ListCount - 1, X - 1) = Sheet2.Cells(i, X)
Next X
End If
Next j
Next i
End Sub
Now that you're generalized your Sub, you can modify the value of ws to repeat the code as much as you need to. If it is every sheet in your workbook, you can use a For Each loop, like
For Each ws In ActiveWorkbook
'All your code for the ws here
Next ws
Or, you can define the worksheets in an array beforehand.
Dim SheetList(0 to 2) As String
Dim k As Integer
SheetList(0) = "Sheet 2 Name"
SheetList(1) = "Sheet 4 Name"
SheetList(2) = "Sheet 3 Name"
SheetList(3) = "Sheet 6 Name"
For k = LBound(SheetList) To UBound(SheetList)
ws = ActiveWorkbook.Sheets(SheetList(k))
'The rest of your code from above
Next k
You didn't specify in your question what kind of sheets how many, or how they are organized. But, these options should be enough to get you where you are trying to go.
I am running sub where it compares two cells (B and D/or string Received) from one sheet ("DATA") with two cells (C, H) from another sheet ("Incoming_report"), and if they match it transposes I, G cells from Incoming to Data.
It is done by combining two cells from Incoming_report sheet and writing new value in Z column for example "123456" from C and H to f.e. "123456Received" (there another 5 statuses (Received, Rejected, Sent...., but I need the ones only that was Received)
Then I am taking from Data Sheet B column for example 123456 and only Received (there might be another 5 statuses, but I only need the one that was received).
That makes all sence to me and works pretty good, but I have to work with more than 500k rows in each sheet. What happens - 500,000 times two cells are combined and searched in Z column in another sheet among another 500,000 for possible match, if nothing found then N/A, and then 2 combination, 3rd, 4th... till 500,000. I added the Display status bar and I see how slowly it goes (only 900 rows per minute, so for one minor mapping it would take more than 10 hours). Here is the sub itself, can anyone share ideas how to improve it to make it work faster? Thanks a million.
Sub incoming_fetch()
Application.ScreenUpdating = False
Dim incr As Long
Dim x As String
n = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
Z = Sheets("Incoming_report").Range("D" & Rows.Count).End(xlUp).Row
For i2 = 2 To Z
Sheets("Incoming_report").Range("Z" & i2).Value = Sheets("Incoming_report").Range("C" & i2).Value & Sheets("Incoming_report").Range("H" & i2).Value
Next i2
For i = 3 To n
Application.DisplayStatusBar = True
Application.StatusBar = i
x = Sheets("Data").Range("B" & i).Value & "Received"
If Sheets("Incoming_report").Range("Z:Z").Find(x, lookat:=xlWhole, LookIn:=xlFormulas) Is Nothing Then
Sheets("Data").Range("L" & i) = "N/A"
Sheets("Data").Range("M" & i) = "N/A"
Else
incr = Sheets("Incoming_report").Range("Z:Z").Find(x, lookat:=xlWhole, LookIn:=xlFormulas).Row
Sheets("DATA").Range("L" & i) = Sheets("Incoming_report").Range("I" & incr)
Sheets("DATA").Range("M" & i) = Sheets("Incoming_report").Range("G" & incr)
End If
Next i
End Sub
EDIT2: fixed source columns :
Sub incoming_fetch()
Dim i As Long, n As Long, z As Long, num As Long
Dim x As String
Dim shtIn As Worksheet, shtData As Worksheet
Dim dict As Object, arrC, arrH, arrG, arrI, v, arr, r1, r2
Dim t
Set dict = CreateObject("scripting.dictionary")
Set shtIn = Sheets("Incoming_report")
Set shtData = Sheets("Data")
n = shtData.Range("A" & Rows.Count).End(xlUp).Row
z = shtIn.Range("D" & Rows.Count).End(xlUp).Row
t = Timer
'get all values from Cols C, H, L, M
arrC = shtIn.Range(shtIn.Range("C2"), shtIn.Range("C" & z)).Value
arrH = shtIn.Range(shtIn.Range("H2"), shtIn.Range("H" & z)).Value
arrG = shtIn.Range(shtIn.Range("G2"), shtIn.Range("G" & z)).Value
arrI = shtIn.Range(shtIn.Range("I2"), shtIn.Range("I" & z)).Value
Debug.Print "Get Arrays: " & Timer - t
t = Timer
'create a lookup dictionary of all the ColC values
' (where ColH = "Received")
num = UBound(arrC, 1)
For i = 1 To num
v = arrC(i, 1)
If arrH(i, 1) = "Received" And Len(v) > 0 Then
dict(v) = Array(arrI(i, 1), arrG(i, 1))
End If
Next i
'free up some memory
Erase arrC: Erase arrH: Erase arrI: Erase arrG
Debug.Print "Filled dict: " & Timer - t
t = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error GoTo haveError
For i = 3 To n
If i Mod 500 = 0 Then Application.StatusBar = i
x = shtData.Range("B" & i).Value
If dict.exists(x) Then
arr = dict(x)
r1 = arr(0)
r2 = arr(1)
Else
r1 = "N/A": r2 = "N/A"
End If
With shtData
.Range("L" & i) = r1
.Range("M" & i) = r2
End With
Next i
Debug.Print "Done: " & Timer - t
haveError:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub