Arrays 查找两个数组之间匹配值的字典替代方法
我一直在寻找一种方法，根据几个条件匹配两个数组，然后在满足这些条件后向该数组写入一个值。我已经这样做了，但这远远不够慢和出色。我试图使用dictionary对象来实现这一点，以加快匹配过程，但我失败得很惨 简单地说，在下面的过程中，我检查某些条件是否正确。如果是这样，然后写入Arrays 查找两个数组之间匹配值的字典替代方法,arrays,excel,vba,dictionary,Arrays,Excel,Vba,Dictionary,我一直在寻找一种方法，根据几个条件匹配两个数组，然后在满足这些条件后向该数组写入一个值。我已经这样做了，但这远远不够慢和出色。我试图使用dictionary对象来实现这一点，以加快匹配过程，但我失败得很惨 简单地说，在下面的过程中，我检查某些条件是否正确。如果是这样，然后写入OutPut\u数组，以便稍后匹配ShtInPut\u数组中的值 Sub Cat_Payments_Test2() Dim InPut_Array As Variant, ShtInPut_Array As Varia
OutPut\u数组ShtInPut\u数组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
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
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
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
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
您有一个很好的理由切换到面向对象的方法-是时候通过创建责任链、简化和拆分成短的独立函数来管理代码的复杂性了。 任务的对象分解可能如下所示：
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
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
面向对象的方法还有许多其他优点。您有一个很好的理由切换到面向对象的方法-是时候通过创建责任链、简化和拆分成短的独立函数来管理代码的复杂性了。 任务的对象分解可能如下所示：
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
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
面向对象的方法还有许多其他优点。似乎是一个快速修复方法，即在找到匹配项后立即退出y循环-无需遍历
InPut\u Array。如果你在没有它的情况下得到错误，那么修复这些错误-不要忽略它们。创建一个类来表示你将在2D数组中放入的内容。给它一个函数匹配（其他）为布尔值
，并在第一部分中使用它。对于第二部分，计算一个散列并将其用作字典键。也许您可以将其作为SQL语句进行返工？@TimWilliams我尝试了退出，并删除了错误恢复下一步时的，Excel仍然崩溃并烧掉，哈哈@共产国际适时地注意到了，我会查清楚的。我还考虑了锯齿数组、嵌套字典或数组字典的可能性，但我需要更多地了解其中的每一种@RyanWildry我实际上是从SQL中获取数据，并将其放入一个记录集
数组中，但用户将更新Excel中记录集的值，然后我有一个上传它们的过程。我当然希望我可以使用所有的SQL功能。似乎一个快速的解决方法是在找到匹配项后立即退出y循环-无需遍历输入数组的其余部分。另外，除非您真的需要它（通常您不需要），否则我会在下一次错误恢复时删除该。如果你在没有它的情况下得到错误，那么修复这些错误-不要忽略它们。创建一个类来表示你将在2D数组中放入的内容。给它一个函数匹配（其他）为布尔值
，并在第一部分中使用它。对于第二部分，计算一个散列并将其用作字典键。也许您可以将其作为SQL语句进行返工？@TimWilliams我尝试了退出，并删除了错误恢复下一步时的，Excel仍然崩溃并烧掉，哈哈@共产国际适时地注意到了，我会查清楚的。我还考虑了锯齿数组、嵌套字典或数组字典的可能性，但我需要更多地了解其中的每一种@RyanWildry我实际上是从SQL中获取数据，并将其放入一个记录集
数组中，但用户将更新Excel中记录集的值，然后我有一个上传它们的过程。我当然希望我能使用所有的SQL功能。我现在正在尝试，我会在5点后回来报告！我在上面的代码中写错了一些东西（现在就去编辑它），这导致了一个错误，但在修复之后，它就可以继续了！！我还为dictionary对象使用了早期绑定，而且速度非常快！你是绝对的男人！！我不知道为什么在你发布后我没有立即接受这个答案（我唯一的猜测是我太激动了，以至于忘记了，哈哈），但是我在复习这个问题时才意识到我没有，所以我很快就接受了。再次感谢！我现在正在尝试，我将在5点后回来报告！我在上面的代码中写错了一些东西（现在就去编辑它），这导致了一个错误，但在修复之后，它就可以继续了！！我还为dictionary对象使用了早期绑定，而且速度非常快！你是绝对的男人！！我不知道为什么在你发布后我没有立即接受这个答案（我唯一的猜测是我太激动了，以至于忘记了，哈哈），但是我在复习这个问题时才意识到我没有，所以我很快就接受了。再次感谢！我同意。我只做了大约8个月的编程，但已经学了很多。我刚开始了一份新工作，在一家航空公司做数据/报告分析师（我写这个程序的全部原因；我发布的只是一小部分），在这个项目快结束时，我真希望我能创建一个带有属性（如Amount、PO Number等）的事务类。我很可能会在我自己的时间里修改它，以实现这种方法。我同意。我只做了大约8个月的编程，但已经学了很多。我刚开始了一份新工作，在一家航空公司做数据/报告分析师（我写这个程序的全部原因；我发布的只是一小部分），在这个项目快结束时，我真希望我能创建一个带有属性（如Amount、PO Number等）的事务类。我很可能会在自己的时间内重新编写它，以实现这一点