|
'---------------------------------------------------------------------------------------
' 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 |
