Option Explicit
Sub Sverdlovsk()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim Application_Calculation As Long
Application_Calculation = Application.Calculation
Application.Calculation = xlCalculationManual
Dim arr As Variant
Dim y As Long
With ActiveSheet
y = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range(.Cells(1, 1), .Cells(y, 4))
End With
SortArr arr
Dim dic As Object
Set dic = GetDic(arr)
Erase arr
arr = DicToArr(dic)
OutArr arr
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = Application_Calculation
End Sub
Sub OutArr(arr As Variant)
Dim wb As Workbook
Set wb = Workbooks.Add(1)
Dim sh As Worksheet
Set sh = wb.Sheets(1)
Dim r As Range
Set r = sh.Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
r = arr
r.ColumnWidth = 30
wb.Saved = True
End Sub
Function DicToArr(dic As Object) As Variant
Dim arr As Variant
Dim y As Long
Dim v1 As Variant
Dim v2 As Variant
Dim v3 As Variant
Dim v4 As Variant
Dim s3 As Double
Dim dic1 As Object
Dim dic3 As Object
Dim i As Byte
For i = 0 To 1
Set dic1 = CreateObject("Scripting.Dictionary") 'Сумма всех регионов ключ месяц
For Each v1 In dic.Keys
For Each v2 In dic.Item(v1).Keys
Set dic3 = CreateObject("Scripting.Dictionary") 'Сумма одного магазина ключ месяц
For Each v3 In dic.Item(v1).Item(v2).Keys
For Each v4 In dic.Item(v1).Item(v2).Item(v3).Items
Select Case i
Case 0
y = y + 1
Case 1
y = y + 1
arr(y, 1) = v1
arr(y, 2) = v2
arr(y, 3) = v3
arr(y, 4) = v4
dic3(v3) = dic3(v3) + v4
End Select
Next
Next
'Магазин Итог месяц
s3 = 0
For Each v3 In dic3.Keys
Select Case i
Case 0
y = y + 1
Case 1
y = y + 1
arr(y, 1) = v1
arr(y, 2) = "Итог " & v2
arr(y, 3) = v3
arr(y, 4) = dic3.Item(v3)
s3 = s3 + arr(y, 4)
End Select
Next
'Магазин все месяцы
Select Case i
Case 0
y = y + 1
Case 1
y = y + 1
arr(y, 1) = v1
arr(y, 2) = "Итог " & v2
arr(y, 3) = Join(dic3.Keys(), "+")
arr(y, 4) = s3
End Select
Next
Set dic3 = CreateObject("Scripting.Dictionary") 'Сумма одного региона ключ месяц
For Each v2 In dic.Item(v1).Keys
For Each v3 In dic.Item(v1).Item(v2).Keys
For Each v4 In dic.Item(v1).Item(v2).Item(v3).Items
dic3(v3) = dic3(v3) + v4
dic1(v3) = dic1(v3) + v4
Next
Next
Next
'Регион Итог месяц
s3 = 0
For Each v3 In dic3.Keys
Select Case i
Case 0
y = y + 1
Case 1
y = y + 1
arr(y, 1) = "Итог " & v1
'arr(y, 2) = v2
arr(y, 3) = v3
arr(y, 4) = dic3.Item(v3)
s3 = s3 + arr(y, 4)
End Select
Next
'Регион все месяцы
Select Case i
Case 0
y = y + 1
Case 1
y = y + 1
arr(y, 1) = "Итог " & v1
arr(y, 2) = v2
arr(y, 3) = Join(dic3.Keys(), "+")
arr(y, 4) = s3
End Select
Next
'--------------------------------------------
'Регион Итог месяц
s3 = 0
For Each v3 In dic1.Keys
Select Case i
Case 0
y = y + 1
Case 1
y = y + 1
arr(y, 1) = "Итог "
'arr(y, 2) = v2
arr(y, 3) = v3
arr(y, 4) = dic1.Item(v3)
s3 = s3 + arr(y, 4)
End Select
Next
'Регион все месяцы
Select Case i
Case 0
y = y + 1
Case 1
y = y + 1
arr(y, 1) = "Итог "
'arr(y, 2) = v2
arr(y, 3) = Join(dic1.Keys(), "+")
arr(y, 4) = s3
End Select
'--------------------------------------------------
Select Case i
Case 0
ReDim arr(1 To 2 * y, 1 To 4)
y = 0
Case 1
End Select
Next
DicToArr = arr
End Function
Function GetDic(arr As Variant) As Object
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim di2 As Object
Dim y As Long
For y = 2 To UBound(arr, 1)
If Not dic.Exists(arr(y, 1)) Then Set dic.Item(arr(y, 1)) = CreateObject("Scripting.Dictionary")
If Not dic.Item(arr(y, 1)).Exists(arr(y, 2)) Then Set dic.Item(arr(y, 1)).Item(arr(y, 2)) = CreateObject("Scripting.Dictionary")
If Not dic.Item(arr(y, 1)).Item(arr(y, 2)).Exists(arr(y, 3)) Then Set dic.Item(arr(y, 1)).Item(arr(y, 2)).Item(arr(y, 3)) = CreateObject("Scripting.Dictionary")
Set di2 = dic.Item(arr(y, 1)).Item(arr(y, 2)).Item(arr(y, 3))
di2.Item(di2.Count) = arr(y, 4)
Next
Set GetDic = dic
End Function
Sub SortArr(ByRef arr As Variant)
Dim wb As Workbook
Set wb = Workbooks.Add(1)
Dim sh As Worksheet
Set sh = wb.Sheets(1)
Dim r As Range
Set r = sh.Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
r = arr
With sh.Sort
.SortFields.Clear
.SortFields.Add Key:=r.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=r.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=r.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
"Январь,Февраль,Март,Апрель,Май,Июнь,Июль,Август,Сентябрь,Октябрь,Ноябрь,Декабрь" _
, DataOption:=xlSortNormal
.SetRange r
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
arr = r
wb.Close False
End Sub
|
