Доброго времени суток, Планетяне!Такой вопрос: забираю всю сводную в массив и создаю подмассивы с номерами строк для каждого из уровней группировки (для того, чтобы потом быстро производить сложные вычисления и промежуточные итоги). Всё работает, кроме самой группировки. Стандартным методом, через отступы, всё корректно, а через массивы (как мне кажется, тот же самый порядок) - не получается.
Что я делаю не так и как в таком случае нужно было?
КОД |
|---|
| Код |
|---|
Option Explicit
Private Sub Analytics()
Dim rng As Range, ar As Range, cl As Range
Dim arr(), arrSh(), x
Dim arrP(), arrC(), arrG(), arrR(), arrT(), arrD() ' подмассивы
Dim tm!, n&, i&
Dim p%, c%, g%, r%, t%, d% ' счётчики подмассивов
Application.ScreenUpdating = 0: Application.DisplayAlerts = 0
tm = Timer: Application.CalculateFull
arrSh = Array("МАССИВЫ", "ОТСТУПЫ")
arr = [_PTdetBody].Value2: n = UBound(arr, 1)
' ========== СОЗДАЁМ ЛИСТЫ ==============================================================
For Each x In arrSh
On Error Resume Next
Worksheets(x).Delete
On Error GoTo er
Worksheets.Add.name = x
Next x
Worksheets(arrSh(0)).Tab.Color = vbGreen
Worksheets(arrSh(1)).Tab.Color = vbRed
Application.DisplayAlerts = 1
' ========== СОБИРАЕМ МАССИВЫ ==========================================================
ReDim arrP(1 To n): ReDim arrC(1 To n): ReDim arrG(1 To n): ReDim arrR(1 To n): ReDim arrT(1 To n): ReDim arrD(1 To n)
For Each x In arr
i = i + 1
If x = "Ведомость" Then p = p + 1: arrP(p) = i: GoTo nx
If x = "Категория" Then c = c + 1: arrC(c) = i: GoTo nx
If x = "Группа" Then g = g + 1: arrG(g) = i: GoTo nx
If x = "Расценка" Then r = r + 1: arrR(r) = i: GoTo nx
If x = "Тип" Then t = t + 1: arrT(t) = i: GoTo nx
d = d + 1: arrD(d) = i
nx:
Next x
ReDim Preserve arrP(1 To p): ReDim Preserve arrC(1 To c): ReDim Preserve arrG(1 To g): ReDim Preserve arrR(1 To r): ReDim Preserve arrT(1 To t): ReDim Preserve arrD(1 To d)
ActiveWindow.DisplayGridlines = 0: [_PTdetBody].Copy [a1] ' Копируем на лист "ОТСТУПЫ"
Columns(1).ColumnWidth = 200
' ========== ГРУППИРУЕМ СТРОКИ
' Рабочий способ
Set rng = Nothing
For i = 5 To 1 Step -1
For Each cl In Cells(1, 1).Resize(n, 1)
If cl.IndentLevel = i Then
If rng Is Nothing Then Set rng = cl Else: Set rng = Application.Union(rng, cl)
End If
Next cl
If Not rng Is Nothing Then
For Each ar In rng.Areas
ar.Rows.Group
Next ar
End If
Next i
Worksheets(arrSh(0)).Activate ' Работаем с другим листом
[a1].Resize(n, 1).Value = arr
' Нерабочий способ
Call file_Group(arrD) ' детали
Call file_Group(arrT) ' типы
Call file_Group(arrR) ' расценки
Call file_Group(arrG) ' группы
Call file_Group(arrC) ' категории
' ========== ФИНИШ
For Each x In arrSh
Worksheets(x).Cells(1, 1).Resize(n, 1).IndentLevel = 0
Worksheets(x).Columns.AutoFit
Worksheets(x).Outline.ShowLevels RowLevels:=1
Next x
MsgBox "Аналитический отчёт успешно сформирован" & vbLf & vbLf & "Время работы макроса (сек.): " & Round(Timer - tm, 2), vbInformation, "ГОТОВО"
GoTo fin
er: MsgBox "Непредвиденная ошибка!", vbCritical, "КРИТИЧЕСКАЯ ОШИБКА"
ex: MsgBox "Отмена выполнения…", vbInformation, "ВЫХОД"
fin: Application.ScreenUpdating = 1: Application.DisplayAlerts = 1
End Sub
' ===========================================================================================
Private Sub file_Group(arr())
Dim x, rng As Range, ar As Range
For Each x In arr
If rng Is Nothing Then Set rng = Cells(x, 1) Else: Set rng = Application.Union(rng, Cells(x, 1))
Next x
If rng Is Nothing Then Exit Sub
For Each ar In rng.Areas
ar.Rows.Group
Next ar
End Sub |
|
