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

Question

I have long searched for a way to match 2 arrays based on several conditions and then write a value to that array after those conditions are met. I HAVE done so, BUT it is far to slow and crashes Excel. I am trying to use the dictionary object to achieve this in an effort to speed up my matching procedure but I am failing miserably.

Simply put, in the below procedure, I am checking if certain conditions are true. If so then then write to OutPut_Array so that I can match the value found in the ShtInPut_Array later.

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

I have been trying to figure this out for a good week or more, and if I told you how many test modules that I have now from skimming SO and literally everywhere else, you would think I am insane. My thoughts where to adapt @TimWilliams idea from This post, but I would need array indexes, not addresses. At this point I need some SO genius. Thanks to all those with ideas, or answers!

Edit: Below is the full working code with @TimWilliams Dictionary Implementation (many many thanks Tim). The only difference is, I choose to use early binding instead of late binding for the Dictionary Object. To do this, you must reference Microsoft Scripting Runtime in the Visual Basic Editor ( VBE ) by selecting Tools > References > Microsoft Scripting Runtime . Early binding adds a bit more speed because you are informing Excel about the object ahead of runtime. It also enables the VBE's intellisense feature, which is nice for quickly accessing the properties and methods of an object.

 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

Something like this:

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

You have a wonderful reason to switch to an object-oriented approach - it's time to manage the complexity of the code by creating chains of responsibility, simplification, and splitting into short independent functions. Object decomposition of the task may look like this:

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

Do not immediately strive for the speed of the code and its quality. First the quality of the code, then the speed. The object-oriented approach has many other advantages.