новенький тут. ищу решение VBA для объединения нескольких именованных диапазонов и удаления дубликатов с суммой в некоторых столбцах. У меня есть 4 диапазона переменных: "ACTUAL", "BUDGET", "FORECAST", "PYEAR". Я хотел бы объединить их в один массив для консолидации. Диапазоны Прогноз / Факт могут потенциально достигать 60К строк. Диапазон данных для Actuals выглядит следующим образом:
Vendor # Crop Gen.Group Genetic Week.Дата приезда Фактический бюджетный прогноз PYear
12345 STRA CSTA AMESTI 22/08/16 22/08/16 3500
12345 STRA CSTA AMESTI 22/08/16 23/08/16 3500
12345 STRA CSTA XXXXXX 22.08.16 22.08.16 3500
Я хочу объединить данные на основе заголовков, указанных в качестве ключа, суммируя значения, перечисленные в последних 4 столбцах: факт, бюджет, прогноз, год
Как объединить отдельные именованные диапазоны, которые находятся на отдельных листах, и создать массив для 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