我很久以来一直在寻找一种根据几种条件来匹配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的想法，但是我需要数组索引，而不是地址。此时，我需要一些SO天才。感谢所有有想法或答案的人！
编辑：以下是@TimWilliams词典实现的完整工作代码（非常感谢Tim）。唯一的区别是，对于Dictionary对象，我选择使用早期绑定而不是 late绑定。为此，必须通过选择工具>引用> 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
答案 0 :(得分：4)
类似这样的东西：
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
答案 1 :(得分：0)
您有一个绝妙的理由要转向面向对象的方法-现在该通过创建责任链，简化并拆分为简短的独立功能来管理代码的复杂性了。 任务的对象分解可能像这样：
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
不要立即争取代码的速度及其质量。首先是代码的质量，然后是速度。 面向对象的方法还有许多其他优点。