MyTetra Share
Делитесь знаниями!
http://lpgtech.ua/ акция газпромнефть гбо метан.
СОЗДАНИЕ ПОЛНОЦЕННОЙ СВОДНОЙ ТАБЛИЦЫ ИЗ НЕСКОЛЬКИХ ЛИСТОВ
16.03.2019
23:43
Текстовые метки: pt,pivot,create pt,создание сводной
Раздел: !Закладки - VBA - Сводные

СОЗДАНИЕ ПОЛНОЦЕННОЙ СВОДНОЙ ТАБЛИЦЫ ИЗ НЕСКОЛЬКИХ ЛИСТОВ
Но есть и более экзотический метод создания сводной из нескольких листов - через подключения. Создается подключение на языке запросов SQL, запрос подсовываем в кэш сводной - и готово, у нас есть сводная из нескольких листов со всем её функционалом.



'---------------------------------------------------------------------------------------

' Module    : mPTFromMultipleSheets

' DateTime  : 07.08.2014 21:43

' Author    : The_Prist(Щербаков Дмитрий)

'             http://www.excel-vba.ru

' Purpose   : Процедура создания сводной таблицы из нескольких листов

'             http://www.excel-vba.ru/chto-umeet-excel/svodnaya-tablica-iz-neskolkix-listov/

'---------------------------------------------------------------------------------------

Option Explicit

 

Sub PTFromMultipleSheets()

    Dim oPTCache As PivotCache, oPT As PivotTable

    Dim sPath As String, sWbFulName As String, sTmpFileName As String

    Dim avSheets

    Dim sCols As String, sQuery As String, sCon As String

    Dim rRes As Range

    Dim li As Long

 

    sPath = ThisWorkbook.Path

    sWbFulName = ThisWorkbook.FullName

    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"

    sTmpFileName = sPath & "TempWbForDB_" & Format(Now, "yyyymmddhhmmss") & ".xls"

    'сюда можно добавить еще листы

    avSheets = Array("План", "Факт") 'например: Array("Январь", "Февраль", "Март", "Апрель")

    'ниже перечисляются заголовки столбцов, на основе которых строится сводная

    'столбцы могут быть в разном порядке, но иметь одинаковые заголовки

    sCols = "[Отделение],[Статья Расходов],[Сумма]"

    'sCols = "*" ' - если необходимо включить все столбцы

    'при этом шапка на всех листах должна быть полностью одинаковая, кол-во столбцов одинаковое

    'данные будут в том порядке, в котором расположены столбцы

    

    Application.ScreenUpdating = False

    If Val(Application.Version) > 11 Then DelCon

    Set rRes = ThisWorkbook.Sheets(1).Cells

    rRes.Clear

    ThisWorkbook.Worksheets(avSheets).Copy

    With ActiveWorkbook

        .SaveAs sTmpFileName

        .Close

    End With

    'создаем строку запроса

    For li = LBound(avSheets) To UBound(avSheets)

        If li > 0 Then

            sQuery = sQuery & " UNION SELECT " & sCols & " FROM [" & avSheets(li) & "$]"

        Else

            sQuery = "SELECT " & sCols & " FROM [" & avSheets(li) & "$]"

        End If

    Next li

    'сначала создаем подключение к временному файлу

    'это поможет избежать ошибок подключения к открытому файлу

    sCon = _

    "ODBC;DSN=Excel Files;DBQ=" & sTmpFileName & ";" & _

           "DefaultDir=" & sPath & ";DriverId=790;" & _

           "MaxBufferSize=2048;PageTimeout=5"

 

    Set oPTCache = ThisWorkbook.PivotCaches.Add(SourceType:=xlExternal)

    With oPTCache

        .Connection = sCon

        .CommandType = xlCmdSql

        .CommandText = sQuery

        Set oPT = .CreatePivotTable(rRes(3, 1))

    End With

    'теперь изменяем в запросе сводной путь к файлу на текущий

    sCon = _

    "ODBC;DSN=Excel Files;DBQ=" & sWbFulName & ";" & _

           "DefaultDir=" & sPath & ";DriverId=790;" & _

           "MaxBufferSize=2048;PageTimeout=5"

    ThisWorkbook.PivotCaches(1).Connection = sCon

 

    With oPT

        'выставляем первоначальные настройки для сводной

        With .PivotFields(1)

            .Orientation = xlRowField

            .Position = 1

        End With

        With .PivotFields(2)

            .Orientation = xlRowField

            .Position = 2

        End With

        .AddDataField .PivotFields("Сумма"), "Сумма по полю Сумма", xlSum

    End With

 

    'удаляем временный файл

    Kill sTmpFileName

    Set oPT = Nothing: Set oPTCache = Nothing

    Application.ScreenUpdating = True

End Sub

'---------------------------------------------------------------------------------------

' Procedure : DelCon

' Purpose   : Процедура удаляет подключения

'             Требуется только для версий, выше 2003

'---------------------------------------------------------------------------------------

Private Sub DelCon()

    On Error Resume Next: ThisWorkbook.Connections(1).Delete: On Error GoTo 0

End Sub


Я специально привел пример именно с ODBC. Если строить на основе ADO(в сводную можно подставить результат запроса через ADO), то сводная хоть и будет полноценной, но при любом изменении в источнике данных придется перестраивать сводную заново. Что не очень удобно, если данных много и уже свою структуру сводной построили.
А такая сводная(через ODBC) имеет прямую связь с источником данных, т.к. подключение хранится в кэше сводной. Поэтому если данные на листах изменятся - надо будет лишь стандартно обновить сводную:

  • выделить любую ячейку сводной таблицы→Правая кнопка мыши→Обновить(Refresh)
  • или вкладка Данные(Data)→Обновить все(Refresh all)→Обновить(Refresh).

Пара важных замечаний(ложек дегтя, если угодно):

  1. таблицы на листах должны иметь все перечисленные в запросе столбцы. Столбцы на листах могут располагаться в разном порядке, но иметь одинаковые заголовки. Если на одном листе заголовок столбца называется "Сумма", а на другом "Sum" - будет ошибка. Вы можете сами регулировать порядок столбцов и их кол-во, перечисляя их в запросе. За это отвечает строка:
    sCols = "[Отделение],[Статья Расходов],[Сумма]"
    Если в одном из листов будет отсутствовать какой-либо столбец - получите ошибку.
    Если указать
    sCols = "*"
    То в сводную будут включены все столбцы таблиц на листах, что избавляет от процедуры их перечисления. Но в данном случае есть свои нюансы: все таблицы на листах могут иметь различное кол-во строк, но столбцы должны быть строго одинаковые - по кол-ву и по порядку. Иными словами шапка должна быть полностью идентична на всех листах. Если на каком-то листе будет лишний столбец - получите ошибку. Если на каком-то листе будет отсутствовать столбец - получите ошибку. Если имена столбцов где-то различаются - получите ошибку.
  2. заголовки не должны содержать запятых, точек и прочих знаков препинания. Лучше использовать исключительно пробел и нижнее подчеркивание. Так же лучше давать короткие имена заголовков.
  3. лучше заголовки располагать в первой строке. Так же, как и для стандартной сводной - не должно быть объединенных ячеек.
  4. на листах не должно быть пустых строк и столбцов. Что имеется ввиду: если на листе нажать Ctrl+End, то выделяется последняя заполненная ячейка листа. По-хорошему это должна быть последняя ячейка таблицы данных. Если при нажатии на Ctrl+End выделяется пустая ячейка правее или(и) ниже таблицы данных - следует удалить эти пустые столбцы справа и строки снизу и сохранить файл.
  5. На листах не должно быть лишних таблиц. На одном листе должна быть только одна таблица.
  6. Лист для создания сводной таблицы должен находиться на первом листе. Если есть желание расположить его на каком-то другом, то надо в строке кода:
    Set rRes = ThisWorkbook.Sheets(1).Cells
    заменить 1 на номер листа для расположения сводной таблицы.

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

  Tips_PT_PTFromMultipleSheets.xls (54,0 KiB, 4 290 скачиваний)

Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования