查找2個數組之間匹配值的字典替代方法

Question

我長期以來一直在尋找一種基於幾種條件來匹配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到實際上在其他任何地方有多少個測試模塊，您會認為我很瘋狂。 我的思緒從何處適應@TimWilliams想法此職位，但我需要數組索引，沒有地址。 此時，我需要一些SO天才。 感謝所有有想法或答案的人！

編輯：下面是使用@TimWilliams詞典實現的完整工作代碼（非常感謝Tim）。 唯一的區別是，我選擇對Dictionary對象使用早期綁定而不是后期綁定 。 要做到這一點，必須通過選擇Tools>參考參考Microsoft腳本運行時在Visual Basic編輯器（VBE）> Microsoft腳本運行時 。 早期綁定可以提高速度，因為您可以在運行時提前通知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

Answer 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

Answer 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

不要立即追求代碼的速度及其質量。 首先是代碼的質量，然后是速度。 面向對象的方法還有許多其他優點。