Корректировка макроса сводных таблиц

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