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
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
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.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.