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

使用LOOP / IFERROR / INDEX / MATCH

2 个答案: