Преобразование сводной таблицы в формулы SUMIFS — бесплатный макрос VBA

Этот пост содержит бесплатный макрос VBA, который преобразует любую сводную таблицу в отчет, содержащий формулы SUMIFS, COUNTIFS или AVERAGEIFS. Если вы хотите очень быстро создать длинную формулу SUMIFS, это ваш билет.

Сводная таблица или Формулы SUMIFS?

Что лучше — сводная таблица или формулы SUMIFS? Это старый вопрос при создании пользовательского отчета или панели мониторинга, и теперь вы можете иметь и то, и другое!

Сводные таблицы

Преимущество сводных таблиц заключается в том, что вы можете быстро создать красиво отформатированный отчет, который обобщает ваши данные. Они очень быстрые и мощные, и экономят много времени.

Недостатком является то, что расположение сводной таблицы на рабочем листе может быть ограничивающим. Вам может потребоваться больше гибкости в структуре обобщенных данных при создании пользовательских диаграмм, панелей мониторинга, интерактивных отчетов и т.д. Сводные таблицы также требуют, чтобы пользователь вручную обновлял их при обновлении исходных данных.

Формулы SUMIFS

Это может привести нас к использованию формул SUMIFS вместо сводной таблицы.

Преимущество формул SUMIFS заключается в том, что вы можете рассчитать сумму на основе нескольких критериев в любом месте таблицы. Они также рассчитываются автоматически при обновлении исходных данных.

Недостатком является то, что SUMIFS — это длинные формулы, которые требуют много времени для ввода. Они также более подвержены ошибкам и требуют большего обслуживания при изменении диапазона исходных данных (добавлены новые строки).

Преобразовать сводную таблицу в формулы SUMIFS

Недавно я работал над проектом, в котором я писал множество формул SUMIFS для перетаскивания чисел на панель инструментов. Формулы SUMIFS отлично подходят для этого, потому что вы можете сделать панель мониторинга интерактивной, используя выпадающие списки (проверка ячеек), и результаты обновляются автоматически.

Моя проблема заключалась в том, что я тратил много времени на написание различных формул SUMIFS. Я хотел быстро создать эти длинные формулы.

Поэтому я написал этот макрос, который берет сводную таблицу и преобразует ее в формулы SUMIFS, COUNTIFS или AVERAGEIFS. Это означает, что вы можете в основном писать формулы, используя удобство сводной таблицы. Когда в вашей сводной таблице есть все поля, необходимые для формулы SUMIFS, вы просто нажимаете кнопку для создания формул.

Что конкретно делает макрос?

Код VBA приведен ниже, и вы также можете скачать рабочую книгу, содержащую этот код. Я также объясню несколько способов использования этого кода ниже.

Вот общее описание того, что делает макрос:

1. Создает новый лист в книге.
2. Копирует оболочку сводной таблицы на новый лист (строки, столбцы, области фильтрации страниц и форматирование).
3. Перебирает каждую ячейку в области значений и создает формулу SUMIFS, COUNTIFS или AVERAGEIFS на новом листе. Формулы имитируют вычисление поля значений в сводной таблице.

Вы можете использовать новый лист в качестве основы для своего настраиваемого отчета или скопировать формулы на другой лист в рабочей книге. Есть много способов, как вы могли бы использовать это.

Написание макроса

Самым сложным в создании этого кода является обработка всех потенциальных макетов сводной таблицы. Сводная таблица может иметь компактную, контурную или табличную форму, а итоги и промежуточные итоги отображаются в разных местах.

Для формул SUMIFS наиболее удобный макет будет табличным с повторяющимися элементами. Но я не хотел ограничивать код только этим, поэтому я попытался приспособить все возможности макета.

Я не могу сказать, что код еще совершенен, но он обрабатывает все макеты, которые я тестировал до сих пор. Я уверен, что вы найдете ошибки, и я буду обновлять код по мере возникновения проблем.

Код VBA

Dim pvt As PivotTable
Dim rSource As Range
Dim wsSource As Worksheet
Dim bTable As Boolean

Sub Convert_Pivot_to_Formulas()
'все ячейки в области значений для формул SUMIFS, COUNTIFS или AVERAGEIFS
'Подробности: ниже приведен список функций, требований и ограничений макроса.
'Характеристики
'- Работает с полями страницы с несколькими элементами в фильтре одного поля страницы.
'- Создает критерии поля страницы по столбцам и создает формулы массива.
' Требования
'- Поля в сводной таблице, содержащие даты, должны быть в том же формате, что и исходные данные.
'- Исходные данные должны быть в той же книге. Это может быть расширено для ссылки на исходные данные в других книгах.
'Ограничения
'- Не работает с сгруппированными полями даты. Диапазоны критериев НЕ существуют в исходных данных.
'Для решения этой проблемы создайте поля группы дат в виде столбцов в исходных данных.
'---------------------------------------------------------------------------------------

Dim pi As PivotItem
Dim pc As PivotCell
Dim pf As PivotField
Dim wsNew As Worksheet
Dim wsPivot As Worksheet
Dim c As Range
Dim lFunction As Long
Dim sSumRange As String
Dim sCritRange As String
Dim sCriteria As String
Dim sFormula As String
Dim sFormulaPage As String
Dim sSearchField As String
Dim sDataSheet As String
Dim lDataRows As Long
Dim sPageRange As String
Dim lCol As Long
Dim bArray As Boolean
Dim sTableName As String
Dim sFormulaArgs As String
Dim sFormulaCnt As String
Dim lLblRow As Long
Dim lLblCol As Long
        
' Установить переменные сводной таблицы
On Error Resume Next
Set pvt = ActiveCell.PivotTable
Set wsPivot = ActiveSheet
On Error GoTo 0

If pvt Is Nothing Then
 MsgBox "Please select a Pivot Table first.", vbOKOnly, "Convert Pivot to Formula Error"
 Exit Sub
 End If

' Проверьте, находятся ли исходные данные в той же книге.
  If Get_Pivot_Source Then
    
  On Error GoTo Err_Handle
    
'-------------------------------------------------------
'1. Создайте новый лист с оболочкой сводной таблицы - фильтр, строки, области столбцов
'-------------------------------------------------------
Set wsNew = Worksheets.Add(after:=ActiveSheet)
sDataSheet = wsSource.Name
lDataRows = rSource.Rows.Count
If bTable Then sTableName = pvt.SourceData
        
' Скопируйте значения сводной таблицы на новый лист
wsPivot.Select
wsPivot.Range(pvt.TableRange1.Address).Copy
With wsNew.Range(pvt.TableRange1.Address)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
End With
        
If pvt.PageFields.Count > 0 Then
wsPivot.Range(pvt.PageRange.Address).Copy
With wsNew.Range(pvt.PageRange.Address)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
End With
End If
        
'-------------------------------------------------------
'2. Добавьте фильтры полей страницы по столбцам в новом листе.
'-------------------------------------------------------
If pvt.PageFields.Count > 0 Then
For Each pf In pvt.PageFields
sPageRange = pf.LabelRange.Offset(, 1).Resize(1,1).Address
sFilter = pf.LabelRange.Offset(, 1).Resize(1, 1).Value
lCol = 0 'offset 1 col to the right
Select Case sFilter
Case "(All)"
'Пропуск
Case "(Multiple Items)"
' Зацикливайте элементы поворота и добавляйте выбранные элементы в диапазон страниц по столбцам.
For Each pi In pf.PivotItems
If pi.Visible Then
wsNew.Range(sPageRange).Offset(, lCol).Resize(1,1).Value = pi.Name
lCol = lCol + 1
End If
Next pi
Case Else ' Один предмет выбран
lCol = 1
wsPivot.Range(sPageRange).Offset(, lCol).Resize(1, 1).Value = wsNew.Range(sPageRange).Offset(, lCol).Resize(1, 1).Value
End Select
               
' Создать строку для формулы
If lCol > 0 Then ' фильтры существуют
If bTable Then
sCritRange = sTableName & "[" & pf.Name & "]"
Else
sSearchField = pf.Name
sCritRange = "'" & sDataSheet & "'!" & rSource.Resize(1).Find(What:=sSearchField, LookAt:=xlWhole).Offset(1).Resize(lDataRows - 1, 1).Address
End If
                    
sCriteria = wsNew.Range(sPageRange).Resize(1, lCol).Address
               
sFormulaPage = sFormulaPage & "," & sCritRange
sFormulaPage = sFormulaPage & "," & sCriteria
End If
                
' Формула IFS должна быть массивом, если в аргументе критерия есть несколько критериев (диапазон)
If lCol > 1 Then bArray = True
                
Next pf
End If
        
'-------------------------------------------------------
'3. Прокрутите каждую ячейку в области значений, чтобы построить формулу.
'-------------------------------------------------------
For Each c In pvt.DataBodyRange.Cells
            
Set pc = c.PivotCell
sFormula = ""
sFormulaArgs = ""
            
'-------------------------------------------------------
'4. Создайте ссылку SUM RANGE для формулы
'-------------------------------------------------------
' Проверьте, является ли функция суммой, количеством или средним
If pc.PivotField.Function = xlSum Or pc.PivotField.Function = xlCount Or pc.PivotField.Function = xlAverage Then
' Подсчитайте критерии, если 0, то это всего и не требуется IFS
sCriteria = ""
        
' Добавить элементы столбца в массив фильтра
If pc.PivotCellType = xlPivotCellValue Then
                    
sDataField = pc.PivotField.SourceName
lFunction = pc.PivotField.Function
                    
' Добавить диапазон сумм
lFunction = pc.PivotField.Function
                    
If bTable Then
sSumRange = sTableName & "[" & pc.PivotField.SourceName & "]"
Else
sSearchField = pc.PivotField.SourceName
sSumRange = "'" & sDataSheet & "'!" & rSource.Resize(1).Find(What:=sSearchField, LookAt:=xlWhole).Offset(1).Resize(lDataRows - 1, 1).Address
End If
                    
'-------------------------------------------------------
'5. Переберите элементы ROW в сводной ячейке и добавьте ссылки на строки в формулу.
'-------------------------------------------------------
If pc.RowItems.Count Then
For Each pi In pc.RowItems
If bTable Then
sCritRange = sTableName & "[" & pi.Parent.Name & "]"
Else
sSearchField = pi.Parent.Name
sCritRange = "'" & sDataSheet & "'!" & rSource.Resize(1).Find(What:=sSearchField, LookAt:=xlWhole).Offset(1).Resize(lDataRows - 1, 1).Address
End If
                              
' Найти адрес диапазона меток сводных ячеек для адреса критерия
' Начните с текущей строки и выполните цикл по диапазону меток до
' Имя элемента сводной таблицы найдено. Требуется из-за разнообразия макетов сводных таблиц.
lLblCol = pi.LabelRange.Column
For lLblRow = c.Row To pi.Parent.LabelRange.Row + 1 Step -1
If Cells(lLblRow, lLblCol).Value = pi.Name Then
sCriteria = Cells(lLblRow, pi.LabelRange.Column).Address
Exit For
End If
Next lLblRow
                        
If sCriteria <> "" Then
sFormulaArgs = sFormulaArgs &amp; "," &amp; sCritRange
sFormulaArgs = sFormulaArgs &amp; "," &amp; sCriteria
End If
                            
sCriteria = ""
  
Next pi
End If
                    
'-------------------------------------------------------
'6. Просмотрите элементы COLUMN в сводной ячейке и добавьте ссылки на ряды в формулу.
'-------------------------------------------------------
If pc.ColumnItems.Count Then
For Each pi In pc.ColumnItems
If bTable Then
sCritRange = sTableName &amp; "[" &amp; pi.Parent.Name &amp; "]"
Else
sSearchField = pi.Parent.Name
sCritRange = "'" &amp; sDataSheet &amp; "'!" &amp; rSource.Resize(1).Find(What:=sSearchField, LookAt:=xlWhole).Offset(1).Resize(lDataRows - 1, 1).Address
End If
                            
' Найти адрес диапазона меток сводных ячеек для адреса критерия
' Начните с текущего столбца и возвращайтесь влево через диапазон меток до
' Имя элемента сводной таблицы найдено. Требуется из-за разнообразия макетов сводных таблиц.
lLblRow = pi.LabelRange.Row
For lLblCol = c.Column To pi.LabelRange.Column Step -1
If Cells(lLblRow, lLblCol).Value = pi.Name Then
sCriteria = Cells(pi.LabelRange.Row, lLblCol).Address
Exit For
End If
Next lLblCol
                            
If sCriteria <> "" Then
sFormulaArgs = sFormulaArgs &amp; "," &amp; sCritRange
sFormulaArgs = sFormulaArgs &amp; "," &amp; sCriteria
End If
                            
sCriteria = ""
Next pi
End If
                    
'-------------------------------------------------------
'7. Формула построения на основе типа функции сводной ячейки
'-------------------------------------------------------
Select Case pc.PivotField.Function
Case xlSum
If sFormulaArgs = "" And sFormulaPage = "" Then 
' Не нужен IFS, когда нет критериев (всего строк / столбцов)
sFormula = "=SUM(" &amp; sSumRange &amp; ")"
Else
If bArray Then
sFormula = "=SUM(SUMIFS(" &amp; sSumRange &amp; sFormulaPage &amp; sFormulaArgs &amp; "))"
Else
sFormula = "=SUMIFS(" &amp; sSumRange &amp; sFormulaPage &amp; sFormulaArgs &amp; ")"
End If
End If
                            
Case xlCount
If sFormulaArgs = "" And sFormulaPage = "" Then 
' Не нужен IFS, когда нет критериев (всего строк / столбцов)
sFormula = "=COUNT(" &amp; sSumRange &amp; ")"
Else
sFormulaCnt = sFormulaPage &amp; sFormulaArgs 
'Не нужно диапазон суммы для показателей                                sFormulaCnt = Right(sFormulaCnt, Len(sFormulaCnt) - 1) 
' обрезать перед запятой
                                
If bArray Then
sFormula = "=SUM(COUNTIFS(" &amp; sFormulaCnt &amp; "))"
Else
sFormula = "=COUNTIFS(" &amp; sFormulaCnt &amp; ")"
End If
End If
                           
Case xlAverage
If sFormulaArgs = "" And sFormulaPage = "" Then 
' Не нужен IFS, когда нет критериев (всего строк / столбцов)
sFormula = "=AVERAGE(" &amp; sSumRange &amp; ")"
Else
sFormula = "=AVERAGEIFS(" &amp; sSumRange &amp; sFormulaPage &amp; sFormulaArgs &amp; ")" 
' AVERAGEIFS не работает с формулой массива, возвращает ошибки
End If
                            
End Select
                    
'-------------------------------------------------------
'8. Добавить формулу на новый лист
'-------------------------------------------------------
If bArray Then
If Len(sFormula) < 255 Then
wsNew.Range(c.Address).FormulaArray = sFormula
Else
'.FormulaArray выдает ошибку, если строка формулы> 255 символов
' Добавить обработку ошибок здесь
End If
Else
wsNew.Range(c.Address).Formula = sFormula
End If
                   
End If
End If
Next c

End If
    
wsNew.Select

Exit Sub
    
Err_Handle:
MsgBox Err.Description &amp; vbNewLine &amp; "Current Cell: " &amp; c.Address, _
vbCritical, "Convert Pivot to Formulas Error"

End Sub


Function Get_Pivot_Source() As Boolean
Dim bReturn As Boolean
' Определите, является ли источник ссылкой на ячейку, именованным диапазоном или таблицей Excel.
' Установите исходные переменные диапазона
' Попробуйте проверить свойство PivotCache.SourceType.
'http://msdn.microsoft.com/en-us/library/office/ff194557.aspx

 On Error GoTo Err_Handler
    
' Установить переменные для выбранной сводной таблицы
bReturn = False
Set rSource = Nothing
Set wsSource = Nothing
bTable = False
   
If pvt.PivotCache.SourceType = xlDatabase Then
If InStr(pvt.SourceData, "[") = 0 Then ' проверить, содержат ли исходные данные имя книги - обойти диапазон внешнего источника - Temp TO DO
If InStr(pvt.SourceData, ":") > 0 Then ' если диапазон источника данных является диапазоном ссылки на ячейку
Set rSource = Application.Evaluate(Application.ConvertFormula(pvt.SourceData, xlR1C1, xlA1))
Else ' если таблица или именованный диапазон используются в качестве диапазона источника данных
Set rSource = Range(pvt.SourceData)
On Error GoTo SkipTable ' проверить, является ли имя источника данных таблицей
Set rSource = Range(pvt.SourceData &amp; "[#All]")
bTable = True
SkipTable:
On Error GoTo 0
End If
Set wsSource = rSource.Parent
bReturn = True
End If
End If
   
Get_Pivot_Source = bReturn

Exit Function
    
Err_Handler:
    
MsgBox "Error in Get_Source_Range procedure."
Get_Pivot_Source = False

End Function

Как реализовать этот код

Не волнуйтесь, если весь этот код заставляет вашу голову кружиться. Скоро выйдет новая надстройка с именем PivotPal, которая будет содержать эту функцию.

Это означает, что вы сможете запускать этот макрос в любое время одним нажатием кнопки.

Добавьте модуль кода в вашу личную книгу макросов

Вы также можете добавить код в свою личную книгу макросов, а затем назначить ей кнопку ленты. Вот статья о том, как создать личную макрокоманду.

На снимке экрана ниже я добавил макрос в свою личную книгу макросов, а затем назначил ей кнопку на вкладке «Формулы» на ленте.

Вы также можете скопировать модуль кода в любую рабочую книгу и изменить или настроить его по мере необходимости. Есть много возможностей с этим кодом.

Работает с таблицами и структурированными ссылками

Код также работает с таблицами Excel и структурированными ссылками. Если ваш диапазон исходных данных представляет собой таблицу, то код создаст гораздо более приятные на вид формулы. Эти формулы более динамичны, когда строки добавляются к исходным данным.

Это означает, что формулы будут автоматически включать любые новые строки, которые добавляются в таблицу (исходные данные). Использование таблиц значительно сократит объем обслуживания, которое потребуется вашим формулам.

Работает с фильтром страницы нескольких критериев

Код будет работать, если в вашей сводной таблице есть фильтр страниц с несколькими выбранными критериями. Код обнаружит, когда в фильтре выбрано несколько критериев, и создаст формулы массива для SUMIFS. Также будут перечислены критерии в столбцах справа от полей страницы.

Как вы можете видеть на рисунке выше, код работает с довольно сложными компоновками. Я не могу гарантировать, что он будет работать в каждом сценарии, но он определенно должен охватывать не только основы.

Статьи по теме

Mynda Treacy недавно написала отличную статью о формулах Interactive Excel и объясняет, как вы можете использовать формулы SUMIFS для своих отчетов и панелей мониторинга. Не забудьте проверить мои бесплатные призы, когда вы записываетесь на один из курсов Mynda.

VBA Сводная таблица Ссылки

Ниже приведены несколько отличных статей и ресурсов для обучения написанию VBA для сводных таблиц. Они действительно помогли мне написать этот код.

• Информационный список полей сводной таблицы Excel VBA — Дебра Далглиш
• Ссылки на диапазоны сводных таблиц в VBA — Джон Пельтье
• Получение исходного диапазона сводной таблицы с помощью VBA — Дик Куслейка