查找两个数组之间匹配值的字典替代方法答案

【问题标题】：Dictionary Alternative to Finding Matching Values Between 2 Arrays查找两个数组之间匹配值的字典替代方法
【发布时间】：2019-01-25 19:37:59
【问题描述】：

我一直在寻找一种方法来根据几个条件匹配 2 个数组，然后在满足这些条件后将一个值写入该数组。我已经这样做了，但是它的速度很慢并且导致 Excel 崩溃。我正在尝试使用字典对象来实现这一点，以加快我的匹配过程，但我失败了。

简单地说，在下面的过程中，我正在检查某些条件是否为真。如果是这样，那么请写信给OutPut_Array，以便我稍后可以匹配ShtInPut_Array 中找到的值。

Sub Cat_Payments_Test2()

  Dim InPut_Array As Variant, ShtInPut_Array As Variant
  Dim OutPut_Array()
  Dim i As Long
  Dim x As Long, y As Long

    With Application
      .ScreenUpdating = False
      .EnableEvents = False
    End With

    'Would have used Value 2, but I want to preseve the Date formating
    InPut_Array = Sheet19.Range("A1:NWH26").Value
    ShtInPut_Array = Sheet14.Range("A2:Z50667").Value

        ReDim OutPut_Array(1 To 3, LBound(InPut_Array, 2) To UBound(InPut_Array, 2))

       'The Part is super fast
        'On Error Resume Next
        For i = LBound(InPut_Array, 2) To UBound(InPut_Array, 2)
            'Case 1: InPut_Array(14, i) is on the first day of the month
            If InPut_Array(15, i) = (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1) Then
                    'Looking for payments On First Day of CurrMonth
                   If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) _
                   And InPut_Array(20, i) > 0 And (InPut_Array(16, i) = InPut_Array(17, i) Or InStr(InPut_Array(16, i), "Reclas") _
                   Or InStr(InPut_Array(16, i), "*Req Adj*")) And Not (InStr(InPut_Array(16, i), "Prior")) Then

                            InPut_Array(25, i) = "Payment"
                            InPut_Array(26, i) = "Repair Order"

                   ElseIf Len(InPut_Array(20, i)) = 7 And IsNumeric(InPut_Array(20, i)) And (InStr(InPut_Array(15, i), "Prior") _
                   Or InStr(InPut_Array(15, i), "Current")) And InPut_Array(19, i) < 0 Then

                            InPut_Array(24, i) = "RO/Accr Adj."
                            InPut_Array(25, i) = "Reversing Entry"
                   End If

            'Case 2 : InPut_Array(14, i) is between the first day of the month and the last day of the month
            ElseIf (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1) < InPut_Array(14, i) < WorksheetFunction.EoMonth(InPut_Array(15, i), 0) Then
                    'Looking for payments MidMonth (i.e. after the FirstDay_CurrMon _
                    but before LastDayCurrMont
                    If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) And InPut_Array(20, i) > 0 And (InPut_Array(16, i) = InPut_Array(17, i) _
                    Or InStr(InPut_Array(16, i), "Reclas") Or InStr(InPut_Array(16, i), "*Req Adj*")) And Not (InStr(InPut_Array(16, i), "Prior")) Then

                            InPut_Array(25, i) = "Payment"
                            InPut_Array(26, i) = "Repair Order"

                            'Write PO Num
                            OutPut_Array(1, i) = InPut_Array(21, i)
                            'Print the first day of the current month's date
                            OutPut_Array(2, i) = DatePart("d", (CDate(InPut_Array(15, i)) - Day(CDate(InPut_Array(15, i))) + 1))
                            'Print the Amount
                            OutPut_Array(3, i) = Abs(InPut_Array(20, i))

                    End If

            'Case 3.1 and 3.2
            ElseIf InPut_Array(15, i) = WorksheetFunction.EoMonth(InPut_Array(15, i), 0) Then
                    If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) _
                    And (InStr(InPut_Array(16, i), "Prior") Or InStr(InPut_Array(16, i), "Current")) _
                    And InPut_Array(20, i) < 0 Then

                            InPut_Array(25, i) = "RO/Accr Adj."
                            InPut_Array(26, i) = "Repair Order"

                            'Write PO Num
                            OutPut_Array(1, i) = InPut_Array(21, i)
                            'Print the first day of the current month's date
                            OutPut_Array(2, i) = DatePart("d", (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1))
                            'Print Amount
                            OutPut_Array(3, i) = Abs(InPut_Array(20, i))

                    'If criteria met for payment on the last day of the Current Month _
                    then do the same as payments for MidMonth
                    ElseIf Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) And InPut_Array(20, i) > 0 And (InPut_Array(16, i) = InPut_Array(17, i) _
                    Or InStr(InPut_Array(16, i), "Reclas") Or InStr(InPut_Array(16, i), "*Req Adj*")) _
                    And Not (InStr(InPut_Array(16, i), "Prior")) Then

                            InPut_Array(25, i) = "Payment"
                            InPut_Array(26, i) = "Repair Order"

                            'PO Num
                            OutPut_Array(1, i) = InPut_Array(21, i)
                            'Print the first day of the current month's date
                            OutPut_Array(2, i) = DatePart("d", (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1))
                            'Print Amount
                            OutPut_Array(3, i) = Abs(InPut_Array(20, i))
                    End If
            End If
        Next i

            'This matching procedure is what is crashing excel
           For x = LBound(ShtInPut_Array, 1) To UBound(ShtInPut_Array, 1)
            For y = LBound(OutPut_Array, 2) To UBound(OutPut_Array, 2)
               If ShtInPut_Array(x, 21) = OutPut_Array(1, y) _
               And DatePart("d", ShtInPut_Array(x, 15)) = OutPut_Array(2, y) _
               And Abs(ShtInPut_Array(x, 20)) = OutPut_Array(3, y) Then

               ShtInPut_Array(x, 25) = "RO/Accr Adj."
               ShtInPut_Array(x, 26) = "Repair Order"
                Exit For
                End If
            Next y
        Next x

        Sheet17.Range("A2").Resize(UBound(ShtInPut_Array, 1), UBound(ShtInPut_Array, 2)) = ShtInPut_Array

           Application.EnableEvents = True

End Sub

我已经花了一周或更长时间试图弄清楚这一点，如果我告诉你我现在有多少测试模块来自略读 SO 和其他任何地方，你会认为我疯了。我的想法是从This 帖子中调整@TimWilliams 的想法，但我需要数组索引，而不是地址。在这一点上，我需要一些天才。感谢所有有想法或答案的人！

编辑： 以下是@TimWilliams 字典实现的完整工作代码（非常感谢蒂姆）。唯一的区别是，对于Dictionary 对象，我选择使用早期绑定 而不是后期绑定。为此，您必须在 Visual Basic 编辑器 (VBE) 中通过选择 Tools > References > Microsoft Scripting Runtime 来引用 Microsoft Scripting Runtime。早期绑定增加了一点速度，因为您在运行前通知 Excel 对象。它还启用了 VBE 的 智能感知功能，这对于快速访问对象的属性和方法非常有用。

 Sub Cat_Payments_Test2()

 Dim InPut_Array As Variant, ShtInPut_Array As Variant
 Dim OutPut_Array()
 Dim i As Long
 Dim x As Long, y As Long
 Dim Dict As Dictionary 'Early Binding
 Dim k As Variant

  With Application
    .ScreenUpdating = False
    .EnableEvents = False
  End With

  'Would have used Value 2, but I want to preseve the Date formating
  InPut_Array = Sheet19.Range("A1:NWH26").Value
  ShtInPut_Array = Sheet14.Range("A2:Z50667").Value

    ReDim OutPut_Array(1 To 3, LBound(InPut_Array, 2) To UBound(InPut_Array, 2))

    For i = LBound(InPut_Array, 2) To UBound(InPut_Array, 2)
        'Case 1: GL/Date (i.e.InPut_Array(14, i)) is on the first day of the month
        If InPut_Array(15, i) = (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1) Then
                'Looking for payments On First Day of CurrMonth
               If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) _
               And InPut_Array(20, i) > 0 And (InPut_Array(16, i) = InPut_Array(17, i) Or _
               InStr(InPut_Array(16, i), "Reclas") Or InStr(InPut_Array(16, i), "*Req Adj*")) _
               And Not (InStr(InPut_Array(16, i), "Prior")) Then

                        InPut_Array(25, i) = "Payment"
                        InPut_Array(26, i) = "Repair Order"

               ElseIf Len(InPut_Array(20, i)) = 7 And IsNumeric(InPut_Array(20, i)) _
               And (InStr(InPut_Array(15, i), "Prior") Or InStr(InPut_Array(15, i), "Current")) _
               And InPut_Array(19, i) < 0 Then

                        InPut_Array(24, i) = "RO/Accr Adj."
                        InPut_Array(25, i) = "Reversing Entry"
               End If

        'Case 2 : GL/Date is between the first day of the month and the last day of the month
        ElseIf (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1) < InPut_Array(15, i) < WorksheetFunction.EoMonth(InPut_Array(15, i), 0) Then
                'Looking for payments MidMonth (i.e. after the FirstDay_CurrMon _
                but before LastDayCurrMont
                If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) And InPut_Array(20, i) > 0 _
                And (InPut_Array(16, i) = InPut_Array(17, i) Or InStr(InPut_Array(16, i), "Reclas") Or InStr(InPut_Array(16, i), "*Req Adj*")) _
                And Not (InStr(InPut_Array(16, i), "Prior")) Then

                        InPut_Array(25, i) = "Payment"
                        InPut_Array(26, i) = "Repair Order"

                        'Write PO Num
                        OutPut_Array(1, i) = InPut_Array(21, i)
                        'Print the first day of the current month's date
                        OutPut_Array(2, i) = DatePart("d", (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1))
                        'Print the Amount
                        OutPut_Array(3, i) = Abs(InPut_Array(20, i))

                End If

        'Case 3.1 and 3.2: If GL/Date is on the last of the month
        ElseIf InPut_Array(15, i) = WorksheetFunction.EoMonth(InPut_Array(15, i), 0) Then
                If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) _
                And (InStr(InPut_Array(16, i), "Prior") Or InStr(InPut_Array(16, i), "Current")) _
                And InPut_Array(20, i) < 0 Then

                        InPut_Array(25, i) = "RO/Accr Adj."
                        InPut_Array(26, i) = "Repair Order"

                        'Write PO Num
                        OutPut_Array(1, i) = InPut_Array(21, i)
                        'Print the first day of the current month's date
                        OutPut_Array(2, i) = DatePart("d", (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1))
                        'Print Amount
                        OutPut_Array(3, i) = Abs(InPut_Array(20, i))

                'If criteria met for payment on the last day of the Current Month _
                then do the same as payments for MidMonth
                ElseIf Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) And InPut_Array(20, i) > 0 _
                And (InPut_Array(16, i) = InPut_Array(17, i) Or InStr(InPut_Array(16, i), "Reclas") Or InStr(InPut_Array(16, i), "*Req Adj*")) _
                And Not (InStr(InPut_Array(16, i), "Prior")) Then

                        InPut_Array(25, i) = "Payment"
                        InPut_Array(26, i) = "Repair Order"

                        'PO Num
                        OutPut_Array(1, i) = InPut_Array(21, i)
                        'Print the first day of the current month's date
                        OutPut_Array(2, i) = DatePart("d", (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1))
                        'Print Amount
                        OutPut_Array(3, i) = Abs(InPut_Array(20, i))
                End If
        End If
    Next i

    '***************************
    'Dictionary Implementation 
    Set Dict = New Dictionary 'Early Binding

    'populate dictionary with composite keys from output array
    For y = LBound(OutPut_Array, 2) To UBound(OutPut_Array, 2)
        k = Join(Array(OutPut_Array(1, y), _
                       OutPut_Array(2, y), _
                       OutPut_Array(3, y)), "~~")
        Dict(k) = True
    Next y

    'compare...
    For x = LBound(ShtInPut_Array, 1) To UBound(ShtInPut_Array, 1)

        k = Join(Array(ShtInPut_Array(x, 21), _
                       DatePart("d", ShtInPut_Array(x, 15)), _
                       Abs(ShtInPut_Array(x, 20))), "~~")

        If Dict.Exists(k) Then
            ShtInPut_Array(x, 25) = "RO/Accr Adj."
            ShtInPut_Array(x, 26) = "Repair Order"
        End If

    Next x
    '***************************

        Sheet17.Range("A2").Resize(UBound(ShtInPut_Array, 1), UBound(ShtInPut_Array, 2)) = ShtInPut_Array

    'Note for those who were curious as _ 
     to why I did't Set Application.ScreenUpdating = True _ 
     It's b/c Excel does so automatically, so not doing so _ 
     pro-grammatically saves a bit of speed  
    Application.EnableEvents = True

End Sub

【问题讨论】：

似乎一个快速的解决方法是在你找到匹配项后立即退出 y 循环 - 无需通过 InPut_Array 的其余部分。此外，除非您真的需要它（通常您不需要），否则我会删除 On Error Resume Next。如果您在没有它的情况下出现错误，请修复这些错误 - 不要忽略它们。
创建一个类来表示您将在二维数组中放入的内容。给它一个Function Matches(other) As Boolean 并在第一部分使用它。对于第二部分，计算一个哈希并将其用作您的字典键。
也许您可以将其重新编写为 SQL 语句？
@TimWilliams 我试过Exit For 并删除了On Error Resume Next，Excel 仍然崩溃并烧毁，哈哈！ @Comintern Duly 指出我会检查一下。我也考虑了锯齿状数组、嵌套字典或数组字典的可能性，但我需要阅读更多关于这些的内容。 @RyanWildry 我实际上是从 SQL 获取数据到 recordset 数组中，但是用户将更新 Excel 中记录集中的值，然后我有一个上传它们的过程。我当然希望我可以使用所有 SQL 功能。

标签： arrays excel vba dictionary

【解决方案1】：

类似这样的：

Dim dict, k
Set dict = CreateObject("scripting.dictionary")

'populate dictionary with composite keys from output array
For y = LBound(OutPut_Array, 2) To UBound(OutPut_Array, 2)
    k = Join(Array(OutPut_Array(1, y), _
                   OutPut_Array(2, y), _
                   OutPut_Array(3, y)), "~~")
    dict(k) = True
Next y

'compare...
For x = LBound(ShtInPut_Array, 1) To UBound(ShtInPut_Array, 1)

    k = Join(Array(ShtInPut_Array(x, 21), _
                   DatePart("d", ShtInPut_Array(x, 15)), _
                   Abs(ShtInPut_Array(x, 20))), "~~") 

    If dict.exists(k) Then
        ShtInPut_Array(x, 25) = "RO/Accr Adj."
        ShtInPut_Array(x, 26) = "Repair Order"
    End If

Next x

【讨论】：

我正在尝试，我会在 5 后回来报告！
我在上面的代码中写错了一些东西（现在要编辑它），这导致了一个错误，但在修复之后它很好！我还对字典对象使用了早期绑定，它是如此之快！你是绝对的男人！
我不知道为什么我没有在你发布后立即接受这个答案（我唯一的猜测是我太兴奋了，我忘记了，哈哈），但我正在审查这个问题才意识到我没有，所以我立即接受了它。再次感谢！

【解决方案2】：

您有充分的理由切换到面向对象的方法 - 是时候通过创建责任链、简化和拆分成简短的独立函数来管理代码的复杂性了。任务的对象分解可能如下所示：

Public Sub Code_All_2_Units_Tests (Optional ByVal msg As Variant)
    Var_Public_Clear _
            to_ClipBoard (_
            Array_walk (_
            Array_Comments_delete (_
            Split_by_vbrclf (_
            in_Quotes_remove (_
            Underscore_replace (_
            Paste_from_clipboard (_
            Settings)))))))
End sub

不要立即争取代码的速度和质量。首先是代码的质量，然后是速度。面向对象的方法还有许多其他优点。

【讨论】：

我同意。我只编程了大约 8 个月，但学到了很多东西。我刚开始在一家航空公司担任数据/报告分析师的新工作（我编写这个程序的全部原因；我发布的只是一小部分），在这个项目接近尾声后，我真的希望我能已创建具有金额、采购订单编号等属性的交易类。我很可能会在我自己的时间重新修改它以实施该方法。