Optimize this Code (Vlookup-like code) - excel

Question

I have 2 files. The first file, which will already be open when the user runs the macro has 5 worksheets. Each worksheet contains an "Order-Item" column in a different location. An example worksheet would look something like this
-Date Time Order-item Order-Quanity
-1020 9:30 item533333 (blank)
-1020 7:30 item733333 (blank)
-1020 2:30 item333332 (blank)
-1020 6:30 item121242 (blank)
After running the macro, the user will select a file to open that looks like this:
-Order-item Order-Quantity
-item121242 183
-item333332 515
-item533333 27
-item333332 761
The macro then goes through every worksheet from the original file. On each worksheet it finds where the order-item column is located then goes through each item on the column. It searches the user-selected file for the order-item (usually column A) and looks up the quantity(always adjacent to order-item column, in this case column B)
After running the original worksheet should look like this:
-Date Time Order-item Order-Quanity
-1020 9:30 item533333 27
-1020 7:30 item733333 515
-1020 2:30 item333332 761
-1020 6:30 item121242 183
I have created a macro that does this but as both files are rather large(the original file has about 10,000 rows and the user-opened file has upto 50,000 rows) my macro takes some time to execute. I realize I could simply do a Vlookup,filldown, then paste values and it would be much quicker; however this is part of a larger automation macro and this isn't feasible. Is there any improvements anyone could suggest to make my code run more efficent or quicker? If so let me know. Thanks!
Public Sub OpenFile()
Dim FilePath As Variant
Dim FileName As String
Dim CurrentWorkbook As String
Dim thisWB As Workbook
Dim openWB As Workbook
Dim sh As Worksheet
Dim lastRow As Long
Dim myRange As Range
Dim FoundCell As Range
Dim counter1 As Long
Dim counter2 As Long
Dim orderColumn As Long
Set thisWB = Application.ActiveWorkbook
CurrentWorkbook = Application.ActiveWorkbook.Name
FilePath = Application.GetOpenFilename(FileFilter:= _
"Excel Workbook Files(*.xl*),*.xl*", MultiSelect:=False, Title:="Select File")
If Not FilePath = False Then
FileName = FilePath
Set openWB = Application.Workbooks.Open(FileName)
FileName = Mid(FileName, InStrRev(FileName, "\") + 1, Len(FileName)) 'extracts filename from path+filename
Else
MsgBox ("File not selected or selected file not valid")
Exit Sub
End If
Application.Workbooks(FileName).Activate
'--------------------------------------------------------------------------------------------------
'--------------gets table range from input box. Defailt is Row A,B--------------------------------
'--------------------------------------------------------------------------------------------------
Set myRange = Application.InputBox( _
"Select Table Range. First Column should be Order-item, Second Column should be Order Grade", _
"Select Range", "$A:$B", , , , , 8)
On Error GoTo 0
'for every worksheet in currentworkbook, find how many rows there are.and find location of _
order-item. then go through each row in the order-item column and compare to column A(order-item) _
on the user selected workbook. if match is found, place column B into order-item column+1
Application.ScreenUpdating = False
For Each sh In thisWB.Worksheets
lastRow = LastRowUsed(sh)
'Find Order Column
Set FoundCell = sh.Rows(1).Find(what:="Order-Item", LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not FoundCell Is Nothing Then
orderColumn = FoundCell.Column
Else
MsgBox ("Couldn't find ""Order-Item"" in Header, exiting macro")
Exit Sub
End If
For counter1 = lastRow To 1 Step -1
For counter2 = myRange.Rows.Count To 1 Step -1
If sh.Cells(counter1, orderColumn) = myRange.Cells(counter2, 1).Value Then
sh.Cells(counter1, orderColumn + 1) = myRange.Cells(counter2, 2)
Exit For
End If
Next
Next
Next
Application.ScreenUpdating = True
End Sub

Answer 1

Why don't you make your VBA use Application.worksheetFunction.VLOOKUP ?

Answer 2

EDIT: updated to handle duplicate Id's.
Sub Tester()
UpdateFromSelection Workbooks("Book3").Sheets("Sheet1").Range("A1:B21")
End Sub
Sub UpdateFromSelection(myRange As Range)
Dim d, rw As Range, tmp, c As Range, arr, i
Set d = GetItemMap()
If d Is Nothing Then Exit Sub
Debug.Print d.Count
If d.Count = 0 Then
MsgBox "nothing found!"
Exit Sub
End If
For Each rw In myRange.Rows
tmp = rw.Cells(1).Value
If Len(tmp) > 0 Then
If d.exists(tmp) Then
arr = d(tmp)
For i = LBound(arr) To UBound(arr)
arr(i).Value = rw.Cells(2).Value
Next i
End If
End If
Next rw
End Sub
Function GetItemMap() As Object
Dim dict As Object, ws As Worksheet
Dim f As Range, lastRow As Long, tmp, arr, ub As Long
Set dict = CreateObject("scripting.dictionary")
For Each ws In ThisWorkbook.Worksheets
Set f = ws.Rows(1).Find(what:="Order-Item", LookIn:=xlValues, _
LookAt:=xlWhole)
If Not f Is Nothing Then
Set f = f.Offset(1, 0)
lastRow = ws.Cells(Rows.Count, f.Column).End(xlUp).Row
Do While f.Row <= lastRow
tmp = Trim(f.Value)
If Len(tmp) > 0 Then
If Not dict.exists(tmp) Then
dict.Add tmp, Array(f.Offset(0, 1))
Else
'can same item# exist > once?
arr = dict(tmp)
ub = UBound(arr) + 1
ReDim Preserve arr(0 To ub)
Set arr(ub) = f.Offset(0, 1)
dict(tmp) = arr
End If
End If
Set f = f.Offset(1, 0)
Loop
Else
MsgBox ("Couldn't find 'Order-Item' in Header!")
Exit Function
End If
Next ws
Set GetItemMap = dict
End Function