Оптимизируйте этот код (код, подобный Vlookup)

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

-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

Я создал макрос, который делает это, но поскольку оба файла довольно большие (исходный файл содержит около 10 000 строк, а открытый пользователем файл содержит до 50 000 строк), мой макрос требует некоторого времени для выполнения. Я понимаю, что могу просто выполнить 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

person John Young    schedule 27.10.2013    source источник
comment
Эй, Тим, не могли бы вы объяснить эти строки для меня, пожалуйста? arr = d(tmp) For i = LBound(arr) To UBound(arr) arr(i).Value = rw.Cells(2).Value Далее мне было интересно, как это устанавливает значения ячеек. И что делает d(tmp)? Я нигде не могу найти использование этого словаря. Каждый пример, с которым я сталкивался, использует одну из функций, таких как add, exists и т. д., когда что-либо делает со словарем. Спасибо за вашу помощь   -  person John Young    schedule 31.10.2013


Ответы (2)


РЕДАКТИРОВАТЬ: обновлено для обработки повторяющихся идентификаторов.

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
person Tim Williams    schedule 27.10.2013
comment
Эй, спасибо, я попробую это и вернусь к вам с результатами. Если вы не возражаете, не могли бы вы объяснить, что такое scripting.dictionary или что он делает? и да, один и тот же элемент # может существовать более одного раза (и часто существует много раз) в книге, в которую загружаются значения. На листе, который пользователь выбирает для поиска, каждый элемент № существует только один раз. - person John Young; 30.10.2013
comment
Я проверил это. Кажется, это работает намного быстрее. Он падает при установке dict(tmp) = Application.Union(dict(tmp),f.Offset(0, 1)) с сообщением о недопустимом использовании Union. После комментирования блока else, содержащего приведенное выше, он работал на первой странице книги, но не на следующих 4. Я изменил несколько строк, чтобы он работал с моей книгой. Для каждого ws в thisWB.Worksheets. Я добавил глобальную переменную с именем thisWB и установил ее для рабочей книги, в которой выполняется код. Перед этим он всегда говорил, что не может найти элемент заказа и выходил из макроса. Сам макрос хранится в личном.xlsb - person John Young; 30.10.2013
comment
Еще одно изменение, которое я сделал, заключается в подпрограмме Tester. Я передаю диапазон, который пользователь выбирает в рабочей книге, которую он выбирает для открытия, в UpdateFromSelection Sub. - person John Young; 30.10.2013
comment
После дальнейшего тестирования: ваш написанный код работает отлично, если в книге есть только 1 лист. Если у меня есть более 1 листа, он вылетает, говоря, что метод «объединение» объекта «приложение» не удалось Ошибка времени выполнения 1004. Если я удалю эту строку из кода, она частично работает, но не может заполнить повторяющиеся значения элемента заказа. Он также не может заполнить ни один лист, кроме первого листа. - person John Young; 30.10.2013
comment
Словарь сценариев — это объект, который позволяет вам хранить вещи (обычные переменные или объекты), связанные с ключом. Поиск по ключу выполняется очень быстро даже для большого количества элементов (я использовал его для >2 миллионов без проблем). Я предполагаю, что Union не удалось, возможно, потому, что на одном листе есть дубликаты. Я не прилагал особых усилий к этой части, потому что не было ясно, будут ли какие-либо дубликаты. - person Tim Williams; 30.10.2013
comment
У вас есть Option Base 1 в верхней части вашего проекта? Если да, вам нужно внести некоторые изменения (или, предпочтительно, удалить его...) - person Tim Williams; 30.10.2013
comment
Я добавил тусклую стрелку вверху, и это удалило недопустимую ошибку редима. Это работает как шарм, большое спасибо. Никогда бы не подумал об этом решении самостоятельно. Время работы сократилось с ~ 7-8 минут до менее 30 секунд. - person John Young; 30.10.2013
comment
Рад, что ты разобрался. Если вы установите Application.Calculation в ручной режим, вы можете получить дополнительное ускорение. Но не забудьте вернуть его в автоматический режим, когда закончите... - person Tim Williams; 30.10.2013

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

person Charles Williams    schedule 27.10.2013