MENU
Главная » Статьи » Без категории
Сводные таблицы. Pivot Tables.
Нарезаем сводную:
Sub Макрос5()
'
' Макрос5 Макрос
Dim o_pivotitem As Object, o_pivotitem2 As Object, sht As Worksheet, o_pivot_name As PivotTable
'ActiveSheet.PivotTables("СводнаяТаблица2").PivotFields("Регион").EnableItemSelection = True
'ActiveSheet.PivotTables("СводнаяТаблица2").PivotFields("Наши города").EnableItemSelection = True

        For Each o_pivotitem In ActiveSheet.PivotTables("СводнаяТаблица1").PivotFields("Наши города").PivotItems
            For Each sht In ThisWorkbook.Worksheets
            sht.Select
                If o_pivotitem <> "" Then
                With ActiveSheet.PivotTables("СводнаяТаблица1").PivotFields("Наши города")
                    cur_town = o_pivotitem.Name
                    .PivotItems(o_pivotitem.Name).Visible = True
                    For Each o_pivotitem2 In .PivotItems
                        If o_pivotitem2.Name <> o_pivotitem.Name Then
                        .PivotItems(o_pivotitem2.Name).Visible = False
                        End If
                    Next
                    .EnableItemSelection = False
                End With
                ActiveSheet.PivotTables("СводнаяТаблица1").PivotFields("Регион").EnableItemSelection = False

            Next
           
            End If
        Next
End Sub

Сохраняем сводную как значение с сохранением формата:
Sub SavePivotAsValueWithFormats()
    Dim pvtTable As PivotTable
    Dim r As Long, c As Long
MacroSpeedON

    On Error Resume Next
    Set pvtTable = ActiveSheet.PivotTables(ActiveCell.PivotTable.Name)
    On Error GoTo 0
    If Not pvtTable Is Nothing Then
        'копируем сводную и вставляем как значения на новый лист
        pvtTable.TableRange2.Copy
        Worksheets.Add
        ActiveSheet.Range("a1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        ActiveSheet.Range("a1").PasteSpecial Paste:=xlPasteColumnWidths

        'если версия не 2007, то переносим форматы со сводной
        If Application.Version <> "12.0" Then
            For c = 1 To Selection.Columns.Count
                For r = 1 To Selection.Rows.Count
    
                    Selection.Cells(r, c).Interior.Color = pvtTable.TableRange2.Cells(r, c).DisplayFormat.Interior.Color
    
                    Selection.Cells(r, c).Font.Name = pvtTable.TableRange2.Cells(r, c).DisplayFormat.Font.Name
                    Selection.Cells(r, c).Font.Size = pvtTable.TableRange2.Cells(r, c).DisplayFormat.Font.Size
                    Selection.Cells(r, c).Font.Color = pvtTable.TableRange2.Cells(r, c).DisplayFormat.Font.Color
                    Selection.Cells(r, c).Font.Bold = pvtTable.TableRange2.Cells(r, c).DisplayFormat.Font.Bold
                    Selection.Cells(r, c).Font.Italic = pvtTable.TableRange2.Cells(r, c).DisplayFormat.Font.Italic
    
                    Selection.Cells(r, c).Borders(xlEdgeLeft).Color = pvtTable.TableRange2.Cells(r, c).DisplayFormat.Borders(xlEdgeLeft).Color
                    Selection.Cells(r, c).Borders(xlEdgeRight).Color = pvtTable.TableRange2.Cells(r, c).DisplayFormat.Borders(xlEdgeRight).Color
                    Selection.Cells(r, c).Borders(xlEdgeTop).Color = pvtTable.TableRange2.Cells(r, c).DisplayFormat.Borders(xlEdgeTop).Color
                    Selection.Cells(r, c).Borders(xlEdgeBottom).Color = pvtTable.TableRange2.Cells(r, c).DisplayFormat.Borders(xlEdgeBottom).Color
    
                    Selection.Cells(r, c).Borders(xlEdgeLeft).LineStyle = pvtTable.TableRange2.Cells(r, c).DisplayFormat.Borders(xlEdgeLeft).LineStyle
                    Selection.Cells(r, c).Borders(xlEdgeRight).LineStyle = pvtTable.TableRange2.Cells(r, c).DisplayFormat.Borders(xlEdgeRight).LineStyle
                    Selection.Cells(r, c).Borders(xlEdgeTop).LineStyle = pvtTable.TableRange2.Cells(r, c).DisplayFormat.Borders(xlEdgeTop).LineStyle
                    Selection.Cells(r, c).Borders(xlEdgeBottom).LineStyle = pvtTable.TableRange2.Cells(r, c).DisplayFormat.Borders(xlEdgeBottom).LineStyle
    
                Next r
            Next c
        End If
    Else
        MsgBox "Выделите ячейку сводной таблицы"
    End If
MacroSpeedOFF
End Sub

Sub MacroSpeedON()
'макрос входа
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
End Sub

Sub MacroSpeedOFF()
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Sub ShowPagesInPivotTable()
'разбить сводную по листам фильтра
    On Error Resume Next
    Application.Dialogs(xlDialogPivotShowPages).Show
End Sub


Ищем сводную на листе:
Sub checkPivot()
    'проверяем выделение на пересечение со сводными
    If ActiveSheet.PivotTables.Count > 0 Then
        For Each cell In ActiveSheet.UsedRange
            On Error Resume Next
            pvtTable = cell.PivotTable.Name
            If Len(pvtTable) > 0 Then
                SelectionCheck = False
                Exit Sub
            End If
        Next cell
    End If
End Sub


Sub Pivot_All_Sum()
'выделяем даты в сводной и поставим вычисления  = доля по строке ( т.е. от города)
    Dim pvtTable As PivotTable
    Dim pvtName As String

    On Error Resume Next
    Set pvtTable = ActiveSheet.PivotTables(ActiveCell.PivotTable.Name)
    On Error GoTo 0
    If Not pvtTable Is Nothing Then
        For Each pvtField In Selection ' DataFields выделяем даты!!!
            With pvtField
                        pvtTable.PivotFields(pvtField.Value).Calculation = xlPercentOfParentRow
                        pvtTable.PivotFields(pvtField.Value).NumberFormat = "0.00%"
            End With
'            On Error Resume Next    'на случай сводной в Модели Данных в Excel 2013
'            pvtField.Value = "Сумма " & Mid(pvtField.Name, InStr(1, pvtField.Name, "по полю"), 1000)
'            On Error GoTo 0
        Next pvtField
    Else
        MsgBox "Сначала поставьте активную ячейку в сводную таблицу!", vbExclamation, "Подсказка"
    End If
End Sub

'сортируем по полю Общий итог
Sub SortPivot()
    Dim pvtTable As PivotTable
    Dim pvtName As String
    On Error Resume Next
    Set pvtTable = ActiveSheet.PivotTables(ActiveCell.PivotTable.Name)
    On Error GoTo 0
    If Not pvtTable Is Nothing Then
    lastcol = pvtTable.PivotColumnAxis.PivotLines.Count
    
    pvtTable.PivotFields("Марка").AutoSort _
        xlDescending, "Сумма по полю Значение", pvtTable.PivotColumnAxis.PivotLines(lastcol), 1

     End If
End Sub

Sub Условное_Форматирование_Сводной()
'выделяем последний диапазон в сводной для форматирования!!!
    Dim pvtTable As PivotTable
    Dim pvtName As String
    On Error Resume Next
    Set pvtTable = ActiveSheet.PivotTables(ActiveCell.PivotTable.Name)
    On Error GoTo 0
    If Not pvtTable Is Nothing Then
        lastcol = pvtTable.PivotColumnAxis.PivotLines.Count
        row1 = Selection.Row
        row2 = Selection.Count + row1 - 1
        For i = 1 To lastcol
            Selection.FormatConditions.AddDatabar
            Selection.FormatConditions(Selection.FormatConditions.Count).ShowValue = True
            Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
            With Selection.FormatConditions(1)
                .MinPoint.Modify newtype:=xlConditionValueAutomaticMin
                .MaxPoint.Modify newtype:=xlConditionValueAutomaticMax
            End With
            With Selection.FormatConditions(1).BarColor
                .Color = 13012579
                .TintAndShade = 0
            End With
            Selection.FormatConditions(1).BarFillType = xlDataBarFillSolid
            Selection.FormatConditions(1).Direction = xlContext
            Selection.FormatConditions(1).NegativeBarFormat.ColorType = xlDataBarColor
            Selection.FormatConditions(1).BarBorder.Type = xlDataBarBorderNone
            Selection.FormatConditions(1).AxisPosition = xlDataBarAxisAutomatic
        Selection.Offset(, -1).Select
        Next
        
     End If
End Sub

 
Категория: Без категории | Добавил: clownsaround (26.03.2017)
Просмотров: 546 | Теги: pivot tables, vba, Сводные таблицы | Рейтинг: 0.0/0
Всего комментариев: 0
Войдите:
avatar