Excel VBA:在几个数组之间复制索引(Match())
Excel VBA:在几个数组之间复制索引(Match())
提问于 2016-08-04 17:32:56
我正在尝试自动化我目前每月手动准备的一份报告，但我遇到了一些问题，使其高效运行。基本上，报告有4项投入：
- 当月YTD开支及储蓄报告(按零件编号划分) 70k行x4 cols
- 当前月份零件编号查找表87k行x8 cols
- 上月YTD开支及储蓄报告(按零件数目划分) 60k行x4 cols
- 上一个月零件编号查找表77k行x8 cols
正如您所看到的，这些是相当大的信息表(当然不是最大的)。到年底，我预计随着我们继续发布更多的零件数量，这些表会变得更大(也许是25%)。
我的目标是得到一个数据表，它结合了所有这些输入，并为几个列做了一些轻松的数学计算。到目前为止，我的代码如下所示：
'Store data from 4 data worksheets into arrays
Dim arrPrevDMCRLookup As Variant
Dim lngFirstPDLRow As Long 'PDL = Previous DMCR Lookup
Dim lngLastPDLRow As Long
Dim lngNumPDLRows As Long
Dim lngNumPDLCols As Long
lngFirstPDLRow = 2 'Does not store header row
lngLastPDLRow = wsPreviousLookupData.UsedRange.Rows.Count
arrPrevDMCRLookup = wsPreviousLookupData.Range("A" & lngFirstPDLRow & ":H" & lngLastPDLRow)
lngNumPDLRows = UBound(arrPrevDMCRLookup, 1) - LBound(arrPrevDMCRLookup, 1) + 1
lngNumPDLCols = UBound(arrPrevDMCRLookup, 2) - LBound(arrPrevDMCRLookup, 2) + 1
Dim arrPrevDMCRPivot As Variant
Dim lngFirstPDPRow As Long 'PDP = Previous DMCR Pivot
Dim lngLastPDPRow As Long
Dim lngNumPDPRows As Long
Dim lngNumPDPCols As Long
lngFirstPDPRow = 5 'Does not store header row
lngLastPDPRow = wsPreviousPivotSheet.UsedRange.Rows.Count
arrPrevDMCRPivot = wsPreviousPivotSheet.Range("A" & lngFirstPDPRow & ":D" & lngLastPDPRow)
lngNumPDPRows = UBound(arrPrevDMCRPivot, 1) - LBound(arrPrevDMCRPivot, 1) + 1
lngNumPDPCols = UBound(arrPrevDMCRPivot, 2) - LBound(arrPrevDMCRPivot, 2) + 1
Dim arrCurrDMCRLookup As Variant
Dim lngFirstCDLRow As Long 'CDL = Current DMCR Lookup
Dim lngLastCDLRow As Long
Dim lngNumCDLRows As Long
Dim lngNumCDLCols As Long
lngFirstCDLRow = 2 'Does not store header row
lngLastCDLRow = wsCurrentLookupData.UsedRange.Rows.Count
arrCurrDMCRLookup = wsCurrentLookupData.Range("A" & lngFirstCDLRow & ":H" & lngLastCDLRow)
lngNumCDLRows = UBound(arrCurrDMCRLookup, 1) - LBound(arrCurrDMCRLookup, 1) + 1
lngNumCDLCols = UBound(arrCurrDMCRLookup, 2) - LBound(arrCurrDMCRLookup, 2) + 1
Dim arrCurrDMCRPivot As Variant
Dim lngFirstCDPRow As Long 'CDP = Current DMCR Pivot
Dim lngLastCDPRow As Long
Dim lngNumCDPRows As Long
Dim lngNumCDPCols As Long
lngFirstCDPRow = 5 'Does not store header row
lngLastCDPRow = wsCurrentPivotSheet.UsedRange.Rows.Count
arrCurrDMCRPivot = wsCurrentPivotSheet.Range("A" & lngFirstCDPRow & ":D" & lngLastCDPRow)
lngNumCDPRows = UBound(arrCurrDMCRPivot, 1) - LBound(arrCurrDMCRPivot, 1) + 1
lngNumCDPCols = UBound(arrCurrDMCRPivot, 2) - LBound(arrCurrDMCRPivot, 2) + 1
'Create array for output data
Dim arrData As Variant
ReDim arrData(1 To lngNumCDPRows, 1 To 21) 'arrData needs to have the same number of rows as arrCurrDMCRPivot and 21 columns
'Fill arrData
Dim i As Long 'Loop variable
Dim j As Long 'Loop variable
For i = 1 To lngNumCDPRows
'Update status bar
Call UpdateStatusBar(1, lngNumCDPRows, i, "Combining reports...")
'Grab data from arrCurrDMCRPivot
arrData(i, 1) = arrCurrDMCRPivot(i, 1) 'Concatenate string
arrData(i, 9) = arrCurrDMCRPivot(i, 2) 'Current Engineering Manager
arrData(i, 10) = arrCurrDMCRPivot(i, 3) 'Current YTD USD Spend
arrData(i, 11) = arrCurrDMCRPivot(i, 4) 'Current YTD USD Savings
'Lookup data from arrCurrDMCRLookup
For j = 1 To lngNumCDLRows
If arrData(i, 1) = arrCurrDMCRLookup(j, 1) Then 'Concatenate strings match
arrData(i, 2) = arrCurrDMCRLookup(j, 2) 'Part number
arrData(i, 3) = arrCurrDMCRLookup(j, 3) 'Part name
arrData(i, 4) = arrCurrDMCRLookup(j, 4) 'Supplier Code
arrData(i, 5) = arrCurrDMCRLookup(j, 5) 'Supplier Name
arrData(i, 6) = arrCurrDMCRLookup(j, 6) 'DMCR Comp Grp
arrData(i, 7) = arrCurrDMCRLookup(j, 7) 'ACSD Org
arrData(i, 12) = arrCurrDMCRLookup(j, 8) 'Current DMCR: Prior Year Average Cost
Exit For 'Stop looking when a match was found
End If
Next j
'Lookup data from arrPrevDMCRPivot
For j = 1 To lngNumPDPRows
If arrData(i, 1) = arrPrevDMCRPivot(j, 1) Then 'Concatenate strings match
arrData(i, 13) = arrPrevDMCRPivot(j, 2) 'Previous Engineering Manager
arrData(i, 14) = arrPrevDMCRPivot(j, 3) 'Previous YTD USD Spend
arrData(i, 15) = arrPrevDMCRPivot(j, 4) 'Previous YTD USD Savings
Exit For 'Stop looking when a match was found
End If
Next j
'Lookup data from arrPrevDMCRLookup
For j = 1 To lngNumPDLRows
If arrData(i, 1) = arrPrevDMCRLookup(j, 1) Then 'Concatenate strings match
arrData(i, 16) = arrPrevDMCRLookup(j, 8) 'Previous DMCR: Prior Year Average Cost
Exit For 'Stop looking when a match was found
End If
Next j
'Calculate remaining fields
Next i因此，正如您所看到的，我使用嵌套循环在数组中复制Index(Match())的功能。但是看看我的状态栏更新，我想我还没有看到它完成一行！
现在，我正在为输出数组的每一行遍历一个可能的224 k行。这是一个潜在的1570万行循环通过！一定有更好的方法，对吧？会用
Application.WorksheetFunction.Index(<column from one of the input arrays>, Application.WorksheetFunction.Match(<concatenate string from output array>,<column from input array containing concatenate strings>,0))工作?如何从要查看的输入数组中指定列？有什么建议可以让这件事以更合理的速度进行吗？
提前感谢您的帮助！
回答 3
Stack Overflow用户
回答已采纳
发布于 2016-08-04 21:06:34
另一个解决方案是映射Collection中的所有行。它将比Dictionary快至少30%，而且它是VBA固有的。
下面是一个数据示例：
Dim mapCurrDMCRLookup As Collection
Set mapCurrDMCRLookup = MapRows(arrCurrDMCRLookup, Column:=1)
For i = 1 To lngNumCDPRows
'Lookup data from arrCurrDMCRLookup
j = GetRow(mapCurrDMCRLookup, arrData(i, 1))
If j > -1 Then ' if found
arrData(i, 2) = arrCurrDMCRLookup(j, 2) 'Part number
...
End If
NextFunction MapRows(data(), Column As Integer) As Collection
Set MapRows = New Collection
On Error Resume Next
Dim r As Long
For r = LBound(data) To UBound(data)
MapRows.Add r, CStr(data(r, Column))
Next
End Function
Function GetRow(map As Collection, value) As Long
On Error Resume Next
GetRow = -1
GetRow = map(CStr(value))
End FunctionStack Overflow用户
发布于 2016-08-04 18:08:41
下面是一个简单的示例，展示了一般方法：
Sub Tester()
Dim i As Long, r As Long, v
'main driving array
Dim arrPrevDMCRPivot As Variant
arrPrevDMCRPivot = GetData(wsPreviousPivotSheet)
'array to be joined in....
Dim arrPrevDMCRLookup As Variant, dictPrevDMCRLookup As Object
arrPrevDMCRLookup = GetData(wsPreviousLookupData)
Set dictPrevDMCRLookup = GetDict(arrPrevDMCRLookup, 1)
'other arrays and lookups here....
For i = 1 To UBound(arrPrevDMCRPivot)
v = arrPrevDMCRPivot(i, 1) 'the lookup value
If dictPrevDMCRLookup.exists(v) Then
r = dictPrevDMCRLookup(v) 'r is the matching row in arrPrevDMCRLookup
'use values from arrPrevDMCRLookup "row" r
'.....
End If
'check other arrays/looups
Next i
End Sub
Function GetData(sht As Worksheet)
Dim arr
With sht.Range("A1").CurrentRegion
arr = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Value
End With
End Function
'get a lookup dictionary key=values from column [colNum], value=row
Function GetDict(arr, colNum As Long)
Dim rv As Object, r As Long
Set rv = CreateObject("scripting.dictionary")
For r = 1 To UBound(arr, 1)
If Not rv.exists(arr(r, colNum)) Then rv.Add arr(r, colNum), r
Next r
Set GetDict = rv
End FunctionStack Overflow用户
发布于 2016-08-04 18:10:01
这是我提议的一个例子，仅供第一个输入表使用。可以将此模式扩展到查找表的其余部分。
Dim DMCRLookupDictionary As New Dictionary
' ...
arrPrevDMCRLookup = wsPreviousLookupData.Range("A" & lngFirstPDLRow & ":H" & lngLastPDLRow)
lngNumPDLRows = UBound(arrPrevDMCRLookup, 1)
lngNumPDLCols = UBound(arrPrevDMCRLookup, 2)
' Build the dictionary mapping lookupKey -> lookupRow
Dim j As Long
For j = 1 To lngNumPDLRows
If Not DMCRLookupDictionary.Exists(arrPrevDMCRLookup(j, 1)) Then
DMCRLookupDictionary.Add(arrPrevDMCRLookup(j, 1), j)
End If
Next j
' ...
For i = 1 To lngNumCDPRows
' ...
If DMCRLookupDictionary.Exists(arrData(i, 1)) Then
j = DMCRLookupDictionary(arrData(i, 1))
arrData(i, 2) = arrCurrDMCRLookup(j, 2)
arrData(i, 3) = arrCurrDMCRLookup(j, 3)
' ...
End If
Next i请注意，这将只匹配在查找表中遇到的第一个值(但是，您的示例代码也是如此)。小心重复的东西。
还需要导入脚本运行时才能访问Dictionary类。Tools > References > Microsoft Scripting Runtime您可以像Dim DMCRLookupDictionary As Object: Set DMCRLookupDictionary = CreateObject("Scripting.Dictionary")一样创建字典来避免这种情况，但我倾向于添加引用并进行更好的类型检查。
页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/38773902
复制相关文章
相似问题
腾讯云开发者
