☰

Excel VBA：从多个命名范围（无重复）创建二维数组，对列求和

tag-icon • tag-icon microsoft-excel microsoft-excel-2010 vba array named-ranges
Excel VBA：从多个命名范围（无重复）创建二维数组，对列求和

新来的。正在寻找一个 VBA 解决方案来合并多个命名范围并删除某些列上的重复项和。我有 4 个变量范围：“ACTUAL”、“BUDGET”、“FORECAST”、“PYEAR”，我想将它们合并为一个数组进行合并。Forecast/Actual 的范围可能达到 60K 行。Actuals 的数据范围如下：

供应商# 作物 Gen.Group 遗传周报日期 实际预算预测年

12345 STRA CSTA AMESTI 22/08/16 22/08/16 3,500

12345 斯特拉 CSTA 阿梅斯蒂 22/08/16 23/08/16 3,500

12345 STRA CSTA XXXXXX 22/08/16 22/08/16 3,500

我想根据列出的标题合并数据，并将最后 4 列中列出的值相加：实际、预算、预测、PYear

如何合并位于单独工作表上的单独命名范围并创建一个数组来 1. 循环并删除重复项，2. 对所需的列求和。

任何帮助是极大的赞赏！！

抱歉-我不知道如何正确添加代码......

到目前为止已经创建了一个类和模块，但它只处理一个范围。在传递以下代码之前，我仍然不知道如何将范围合并为一个：

Option Explicit
Private pID As String
Private pVendor As String
Private pCrop As String
Private pGenGrp As String
Private pGenetic As String
Private pWcomm As Date
Private pDate As Date
Private pAct As Double
Private pBud As Double
Private pPyr As Double
Private pFct As Double

Public Property Get MergeKey() As String
MergeKey = pID
End Property 
Public Property Let MergeKey(value As String)
pID = value
End Property
Public Property Get Vendor() As String
Vendor = pVendor
End Property
Public Property Let Vendor(value As String)
pVendor = value
End Property
Public Property Get Genetic() As String
Genetic = pGenetic
End Property
Public Property Let Genetic(value As String)
pGenetic = value
End Property
Public Property Get GrDate() As Date
GrDate = pDate
End Property
Public Property Let GrDate(value As Date)
pDate = value
End Property
Public Property Get WeekComm() As Date
WeekComm = pWcomm
End Property
Public Property Let WeekComm(value As Date)
pWcomm = value
End Property
Public Property Get Crop() As String
Crop = pCrop
End Property
Public Property Let Crop(value As String)
pCrop = value
End Property
Public Property Get Actual() As Double
Actual = pAct
End Property
Public Property Let Actual(value As Double)
pAct = value
End Property
Public Property Get Budget() As Double
Budget = pBud
End Property
Public Property Let Budget(value As Double)
pBud = value
End Property
Public Property Get Forecast() As Double
Forecast = pFct
End Property
Public Property Let Forecast(value As Double)
pFct = value
End Property
Public Property Get GeneticGroup() As String
GeneticGroup = pGenGrp
End Property
Public Property Let GeneticGroup(value As String)
pGenGrp = value
End Property

以下是模块代码：

Sub DailyVolumes()
Dim eSrc As Range  
Dim wseSrc As Worksheet

Dim vSrc As Variant
Dim cV As cItems, colDaily As Collection
Dim vVarRanges As Variant
Dim vRes() As Variant, rRes As Range

Dim vResults() As Variant
Dim sKey As String
Dim i As Long, J As Long, K As Long

Set wseSrc = Worksheets("CONSOL")
Set eSrc = wseSrc.Range("G1:P1")
Set rRes = wseSrc.Range("G1")
'Read Named ranges to array
vVarRanges = Range("ACTUALS")
vSrc = vVarRanges

'Collect the Daily volumes into a Collection keyed to Merge ID
 Set colDaily = New Collection
 On Error Resume Next
 For i = 2 To UBound(vSrc, 1)
  Set cV = New cItems
  With cV
        .MergeKey = vSrc(i, 1)
        .Vendor = vSrc(i, 2)
        .Genetic = vSrc(i, 3)
        .GrDate = vSrc(i, 4)
        .WeekComm = vSrc(i, 5)
        .GeneticGroup = vSrc(i, 6)
        .Crop = vSrc(i, 7)
        .Actual = vSrc(i, 8)
        .Forecast = vSrc(i, 9)
        .Budget = vSrc(i, 10)
        sKey = CStr(.MergeKey)
        colDaily.Add cV, sKey
'If the record for this Merge ID already exists, then add the values to the existing record
  If Err.Number = 457 Then
        With colDaily(sKey)
              .Actual = .Actual + cV.Actual
              .Forecast = .Forecast + cV.Forecast
              .Budget = .Budget + cV.Budget
        End With
  ElseIf Err.Number <> 0 Then MsgBox (Err.Number)
  End If
  Err.Clear
  End With
Next i
On Error GoTo 0


'To minimise chance of out of memory errors with large data
'Erase vSrc
'vSrc = eSrc.Rows(1)

'Write the collection to a "Results" array, then write it to the worksheet and format
ReDim vRes(0 To colDaily.Count + 1, 1 To 10)
  For i = 1 To UBound(vRes, 2)
        vRes(0, i) = vSrc(1, i)
  Next i
  For i = 1 To colDaily.Count
        With colDaily(i)
        vRes(i, 1) = .MergeKey
        vRes(i, 2) = .Vendor
        vRes(i, 3) = .Genetic
        vRes(i, 4) = .GrDate
        vRes(i, 5) = .WeekComm
        vRes(i, 6) = .GeneticGroup
        vRes(i, 7) = .Crop
        vRes(i, 8) = .Actual
        vRes(i, 9) = .Forecast
        vRes(i, 10) = .Budget
        End With
  Next i

  With rRes.Resize(UBound(vRes), UBound(vRes, 2))
        .EntireColumn.Clear
        .value = vRes
  End With
  End Sub

答案1

如果您在处理之前确实不需要将命名范围合并为单个范围，则只需一次处理一个即可。以下是一种方法：

Dim arrRanges As Variant, rngCntr As Long
arrRanges = Array("ACTUAL","BUDGET","FORECAST","PYEAR")

'Collect the Daily volumes into a Collection keyed to Merge ID
 Set colDaily = New Collection

 For rngCntr = 0 To UBound(arrRanges)
 vSrc = arrRanges(rngCntr)

 On Error Resume Next
 For I = 2 To UBound(vSrc, 1)
  Set cV = New cItems
  ...
  ...
Next I
On Error GoTo 0

Next rngCntr

您也可以使用For Each ...循环，但是对于如此小的数组，我怀疑您是否会看到任何差异。

相关内容