使用 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

不确定这是否完全满足您的需求，也不是最优雅的解决方案 - 并且没有时间让它变得更好......

它可能不适合你直接开箱即用，但我希望它能让你了解如何更好地解决这个问题。

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 或通过循环执行此操作，具体取决于您的需要。

我会在以后有更多时间（工作！）时尝试完成答案。

Answer 2

使用连接的 B 和 D 列作为键和 E 列作为项目来构建数据表值的字典。这将为 Exportsheet 工作表上的 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