Оптимизируйте этот код (Vlookup-like code)

Question

У меня есть 2 файла. Первый файл, который уже будет открыт, когда пользователь запускает макрос, имеет 5 рабочих листов. Каждый лист содержит столбец «Order-Item» в другом месте. Пример рабочий лист будет выглядеть как этот

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

После запуска макроса, пользователь выбирает файл, чтобы открыть который выглядит следующим образом:

-Order-item Order-Quantity 
-item121242 183 
-item333332 515 
-item533333 27 
-item333332 761 

Макрос затем проходит через каждый лист от оригинала файл. На каждом листе он находит, где находится столбец позиции заказа, затем проходит через каждый элемент в столбце. Он ищет выбранный пользователем файл для позиции заказа (обычно столбец A) и просматривает количество (всегда рядом с столбцом заказа, в этом случае столбец B)

После запуска оригинального листа должно выглядеть следующим образом: :

-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 

Я создал макрос, который делает это, но, как оба файла довольно большой (исходный файл имеет около 10000 строк и пользователь открыл файл имеет Шифрование до 50000 строк) мой макрос занимает некоторое время, чтобы выполнить. Я понимаю, что могу просто сделать Vlookup, заполнить, а затем вставить значения, и это будет намного быстрее; однако это часть более крупного макроса автоматизации, и это невозможно. Есть ли какие-либо улучшения, которые кто-либо может предложить сделать мой код более эффективным или быстрым? Если да, дайте мне знать. Благодаря!

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

EDIT: обновлен для обработки дубликатов идентификаторов.

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 

Answer 2

Почему вы не используете свой VBA Application.worksheetFunction.VLOOKUP?