Сводные. Классические. Как узнать, какие поля исходной таблицы участвуют в строках сводной, Макрос оптимального форматирования "уровней" (строк) сводной таблицы
Вопрос: как быстрее/лучше/оптимальнее всего узнать, какие поля исходной плоской таблицы участвуют в строках сводной на её основе?
Зачем: сначала написал макрос по созданию стиля сводной, но он рассчитан только на 3 подзаголовка строки, а также весьма ограничен по форматированию.
Подробности: Сейчас использую выделение (PivotSelect). Удобно, т.к. всё-равно "красить". но неудобно для предварительного анализа (+ это метод не работает с "ручным"/ManualUpdate обновлением сводной, что может значительно увеличить общее время работы макроса). То есть настроено 5 уровней "раскрашивания"/форматирования. Всё, что более 5ти - без форматирования (это понятно), но, если уровней, например, всего 3, то хотелось бы 2 красить, а третий не трогать — иначе говоря, перед выделением хотелось бы "посчитать" количество уровней (N), чтобы потом N-1 (но не более 5ти) передать в раскрашивание.
В примере всё должно быть понятнее, чем на словах. Ссылки на матчасть присутствуют. И, как всегда, замечания и улучшения по коду только приветствуются
КОД
Код
Option Explicit
Const pt_lvl_1 As Long = 65535 ' жёлтый
Const pt_lvl_2 As Long = 9568145 ' салатовый
Const pt_lvl_3 As Long = 16777110 ' голубой
Const pt_lvl_4 As Long = 6579300 ' тёмно-серый
Const pt_lvl_5 As Long = 13158600 ' светло-серый
'============================================================================================================
Private Sub РаскраситьПоУровням()
Dim pt As PivotTable
Dim rng As Range
Dim c As Byte, n As Byte
On Error Resume Next
Set pt = ActiveSheet.PivotTables(1)
If Err Then MsgBox "На активном листе отсутствует классическая сводная таблица!", vbCritical, "ОШИБКА ЗАПУСКА": GoTo ex
Application.ScreenUpdating = 0: On Error GoTo er
'pt.ManualUpdate = 1
Call ОчиститьФорматирование
For c = 1 To pt.PivotFields.Count
Err = 0
On Error Resume Next: pt.PivotSelect "'" & pt.PivotFields(c).Name & "'", xlDataAndLabel + xlFirstRow
If Err.Number = 0 Then
Set rng = Selection: n = n + 1: On Error GoTo er
With rng
Select Case n
Case 1
.Interior.Color = pt_lvl_1
.HorizontalAlignment = xlCenter
.Font.Bold = 1
.Borders.Weight = xlThick
.Borders(xlInsideHorizontal).Weight = xlThick
.Borders(xlInsideVertical).Weight = xlThick
Case 2
.Interior.Color = pt_lvl_2
.HorizontalAlignment = xlCenter
.Font.Bold = 1
.Borders.Weight = xlThick
.Borders(xlInsideHorizontal).Weight = xlThick
.Borders(xlInsideVertical).Weight = xlThick
Case 3
.Interior.Color = pt_lvl_3
.HorizontalAlignment = xlCenter
.Font.Bold = 1
.Borders.Weight = xlThick
.Borders(xlInsideHorizontal).Weight = xlThick
.Borders(xlInsideVertical).Weight = xlThick
Case 4
.Interior.Color = pt_lvl_4
.Font.Color = vbWhite
.HorizontalAlignment = xlCenter
Case 5
.Interior.Color = pt_lvl_5
.HorizontalAlignment = xlCenter
Case Else: Exit For
End Select
End With
Set rng = Nothing
End If
Next c
GoTo fin
er: MsgBox "Обратитесь к разработчику!", vbCritical, "НЕПРЕДВИДЕННАЯ ОШИБКА"
ex: MsgBox "Отмена выполнения…", vbInformation, "ВЫХОД"
fin: Application.ScreenUpdating = 1
'pt.ManualUpdate = 0
End Sub
'============================================================================================================
Private Sub ОчиститьФорматирование()
ActiveSheet.PivotTables(1).TableStyle2 = ""
With ActiveSheet.PivotTables(1).TableRange1
.Font.Bold = 0
.WrapText = True
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.Interior.Pattern = xlNone
.Borders.LineStyle = 1
.Borders.Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlInsideVertical).Weight = xlThin
End With
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Option Explicit
Private Sub РаскраситьПоУровням()
Dim pt As PivotTable
Dim rng As Range, arr()
Dim c As Byte, n As Byte
On Error Resume Next
arr = Array("65535", "9568145", "16777110", "6579300", "13158600")
Set pt = ActiveSheet.PivotTables(1)
If Err Then MsgBox "На активном листе отсутствует классическая сводная таблица!", vbCritical, "ОШИБКА ЗАПУСКА": GoTo ex
Application.ScreenUpdating = 0: On Error GoTo er
'pt.ManualUpdate = 1
'Call ОчиститьФорматирование
For c = 1 To pt.PivotFields.Count
Err = 0
On Error Resume Next: pt.PivotSelect "'" & pt.PivotFields(c).Name & "'", xlDataAndLabel + xlFirstRow
If Err.Number = 0 Then
Set rng = Selection: n = n + 1: On Error GoTo er
With rng
Select Case n
Case 1 To 3
.Font.Bold = 1
.Borders.Weight = xlThick
.Borders(xlInsideHorizontal).Weight = xlThick
.Borders(xlInsideVertical).Weight = xlThick
Case 4
.Font.Color = vbWhite
Case Is > 5, Is < 1: Exit For
End Select
.Interior.Color = arr(n - 1)
.HorizontalAlignment = xlCenter
End With
Set rng = Nothing
End If
Next c
GoTo fin
er: MsgBox "Обратитесь к разработчику!", vbCritical, "НЕПРЕДВИДЕННАЯ ОШИБКА"
ex: MsgBox "Отмена выполнения…", vbInformation, "ВЫХОД"
fin: Application.ScreenUpdating = 1
'pt.ManualUpdate = 0
End Sub
"Все гениальное просто, а все простое гениально!!!"
Nordheim, ну да — интересно "запихнули" одинаковые операции - спасибо за урок)) код "похудел", но выигрыша в скорости, думаю, не будет. Да и не очень удобно массив использовать, т.к. в оригинале константы являются публичными, лежат в надстройке и используются в нескольких макросах. А как способ и идея - отлично! по основному вопросу есть идеи?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous написал: но выигрыша в скорости, думаю, не будет
дело не в выигрыше в данном случае, а в компактности кода. Изменения можно вообще вынести в отдельную процедуру. а массив заполнить внутри основной (или если использовать отделную то в ней) процедуры константами. Что то типа
а вот такого я ещё не делал (ещё интересен цикл по переменным) , спасибо!
TheBestOfTheBest, а вы уверены, что в этом часовом практикуме есть ответ на мой вопрос? Хотелось бы всё-таки часть кода, т.к. создавать сводные кодом я не планирую…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Nordheim, спасибо вам! Я понял по поводу наполнения массива, а цикл - уже совсем другая история (тема)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Привет, Алексей. Не вдаваясь в подробность раскраски, собственно по вопросу темы, можно перебрать таким образом
Код
Public Sub scanPivotRow()
Dim pSheet As Worksheet
Dim pPivot As PivotTable
Dim pRows As PivotFields
Dim nextRow As PivotField
Dim visibleCollection As PivotItems
Dim nextItem As PivotItem
Dim repeatTabs As String
Set pSheet = ActiveSheet
Set pPivot = pSheet.PivotTables(1)
Set pRows = pPivot.RowFields
For Each nextRow In pRows
repeatTabs = String(nextRow.Position, vbTab)
Debug.Print repeatTabs & nextRow.Caption
Set visibleCollection = nextRow.VisibleItems
For Each nextItem In visibleCollection
If nextItem.RecordCount > 0 Then Debug.Print repeatTabs & vbTab & nextItem.Caption & " == " & nextItem.LabelRange.Address
Next
Next
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Более простой вариант для последующей массовой расскраски
Скрытый текст
Код
Public Sub testColorizePivotRow()
Dim pPivot As PivotTable
Dim pSheet As Worksheet
Dim levelRanges As Object
Set pSheet = ActiveSheet
Set pPivot = pSheet.PivotTables(1)
Set levelRanges = GetPivotLevelRowRanges(pPivot)
levelRanges(3).Interior.Color = vbBlue
End Sub
Public Function GetPivotLevelRowRanges(ByVal forPivot As PivotTable) As Object
Dim levelDict As Object
Dim nextRow As PivotField
Dim nextItem As PivotItem
Dim rowOffset As Long, rowPosition As Long
Dim pivotRange As Range, addRange As Range
Set levelDict = CreateObject("Scripting.Dictionary")
Set pivotRange = forPivot.TableRange1
rowOffset = 1 - pivotRange.Row
For Each nextRow In forPivot.RowFields
rowPosition = nextRow.Position
For Each nextItem In nextRow.VisibleItems
If nextItem.RecordCount > 0 Then
Set addRange = pivotRange.Rows(nextItem.LabelRange.Row + rowOffset)
If Not levelDict.Exists(rowPosition) Then
Set levelDict(rowPosition) = addRange
Else
Set levelDict(rowPosition) = Application.Union(levelDict(rowPosition), addRange)
End If
End If
Next
Next
Set GetPivotLevelRowRanges = levelDict
End Function
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄