Sub MakePivotTables()
' Процедура создает 14 сводных таблиц
Dim PTCache As PivotCache
Dim PT As PivotTable
Dim SummarySheet As Worksheet
Dim ItemName As String
Dim Row As Integer, i As Integer

Application.ScreenUpdating = False

' Удаление листа сводных таблиц, если он существует
On Error Resume Next
Application.DisplayAlerts = False
Sheets("СводныеТаблицы").Delete
On Error GoTo 0

' Добавление листа сводных таблиц
Set SummarySheet = Worksheets.Add
ActiveSheet.Name = "СводныеТаблицы"

' Создание объекта PivotCache
Set PTCache = ActiveWorkbook.PivotCaches.Add( _
SourceType:=xlDatabase, _
SourceData:=Sheets("Данные").Range("A1"). _
CurrentRegion.Address)

Row = 1
For i = 1 To 14
ItemName = Sheets("Данные").Cells(1, i + 2)
' Создание сводной таблицы
Set PT = PTCache.CreatePivotTable _
(TableDestination:=SummarySheet.Cells(Row, 1), _
TableName:=ItemName)
Row = Row + 11

' Добавление полей
With PT.PivotFields(ItemName)
.Orientation = xlDataField
.Name = "Кол-во"
End With

With PT.PivotFields(ItemName)
.Orientation = xlDataField
.Name = "Процент"
.Calculation = xlPercentOfTotal
End With

PT.AddFields RowFields:=Array(ItemName, "Данные")
PT.PivotFields("Пол").Orientation = xlColumnField
PT.PivotFields("Данные").Orientation = xlColumnField
Next i

' Замена оценок описательным текстом
SummarySheet.Activate
With Columns("A:A")
.Replace "1", "Категорически не согласен"
.Replace "2", "Не согласен"
.Replace "3", "Затрудняюсь ответить"
.Replace "4", "Согласен"
.Replace "5", "Полностью согласен"
End With

' Настройка ширины столбцов
Columns("A:G").EntireColumn.AutoFit
End Sub

Scio me nihil scire

<<Jojo®>>

нада исходник ?

Scio me nihil scire

<<Jojo®>>