Несовпадение типов с помощью LOOP / IFERROR / INDEX / MATCH

Question

То, что я пытаюсь сделать, это перебирать все строки и столбцы, чтобы найти количество детали внутри машины. Поиск производится по номеру артикула и типу оборудования / машины. Как на этом скриншоте:

Моя проблема в том, что у меня сейчас работает ОЧЕНЬ медленно. На скриншоте выше только небольшая часть клеток. Они снижаются до + -500, что примерно в 22500 раз больше формулы:

=ifERROR(INDEX(Datasheet!$B$1:$E$100;MATCH(1;(Datasheet!$D:$D=C$1)*(Datasheet!$B:$B=$AY15);0);4);"")

Я хочу ускорить его с помощью VBA, просто указав мои статические значения во всех ячейках. Я сделал большую часть, которую я покажу ниже.

Поиск значений (таблица данных)

У меня это почти завершено (я чувствую это!), Но оно продолжает возвращать мне ошибку несоответствия типов 13. Я обнаружил МНОГИЕ МНОГИЕ потоки при переполнении стека и в Интернете, но эти исправления не решают проблему самостоятельно.

Мой код:

'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

Это как-то связано с тем, что диапазон не может равняться значению, но я пытался в течение долгого времени и не могу понять это.

Также обратите внимание, что цикл, вероятно, не работает, но для решения следующей проблемы: -).

Я не ожидаю, что вы полностью создадите все, но, опять же, дружеский толчок также очень ценится.

ОБНОВЛЕНИЕ: Строка, в которой возникает ошибка:

Esht.Cells(j, i).Value = Application.WorksheetFunction _
        .IfError(Application.WorksheetFunction _
        .Index(SearchRange, Application.WorksheetFunction _
        .Match(1, (MachineMatchCOL = MachineType) * (ArticleMatchCOL = ArticleNumber), 0), 4), "")

Answer 1

Создайте словарь значений таблицы, используя столбцы B & D, соединенные в качестве ключа, и столбец E в качестве элемента.Это обеспечит практически мгновенный поиск в виде «двух столбцов» для таблицы C15: AU29 на рабочем листе таблицы экспорта.

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

Answer 2

Не уверен, что это точно соответствует вашим потребностям, и не является самым элегантным решением - и не хватает времени, чтобы сделать его еще лучше ...

Это может не сработать для вас прямо из коробки, но я надеюсь, что это даст вам представление о том, как лучше подойти к этому.

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: Вам все еще нужно записать значения обратно на лист из массива, что вы можете сделать напрямую range = array или через цикл, в зависимости от ваших потребностей.

Я постараюсь завершить ответ позже, когда у меня будет больше времени (на работе!).