Function FnCreateCon()

'

' Макрос5 Макрос

Dim strShActName As String: strShActName = ActiveSheet.Name

Dim oWb As Workbook

Dim strShConName As String

Dim oConOld As Object 'ODBCConnection ' .Connection

Set oWb = ThisWorkbook

strShConName = "Main_Pt"

strPath = oWb.Path '"<path_to_folder_or_file>"

strDataName = "Старение_авто.accdb"

strConName = "Старение_авто"

strConString = "ODBC;DBQ=" & strPath & "\" & strDataName & ";DefaultDir=" & strPath & _

";Driver={Microsoft Access Driver (*.mdb, *.accdb)};DriverId=25;Exclusive=0;FIL=MS Access;MaxBufferSize=2048;" & _

"MaxScanRows=8;PageTimeout=5;ReadOnly=1;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"

strSQL = "SELECT Дата, ПЖИ, Зона, Дата_ТСМ, Цвет, Тип, Dept, Критерий, Описание, Место, ФИО, Дата_MADU, Текущая_зона, Группа, Проверка_344, CLES" & Chr(13) & "" & Chr(10) & _

"FROM Старение_авто Старение_авто"

' Sheets.Add After:=ActiveSheet

With oWb

On Error GoTo F:

Set oConOld = .Connections(strConName) '.Delete

oConOld.Name = strConName & "Old"

F:

'Создаем новое

oWb.Connections.Add2 strConName, Description:="", _

ConnectionString:=strConString, _

CommandText:=strSQL, _

lCmdType:=xlCmdSql, _

CreateModelConnection:=False, _

ImportRelationships:=False

' ', Password="""", User ID=Admin

End With

m_Pt.FnCreatePtInConnection oWb, strConName

arShPtName = Split("Сводная из архива", ", ", -1, vbTextCompare) 'список листов передаем в массиве

m_Pt.FnIditIndexPT strShConName, arShPtName

oConOld.Delete

Sheets(strShActName).Select

End Function

'==================================================

''==================================================

'''удаляет неиспользуемые подключения

''

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

'Function ConnectEmptyDelete(oWb As Object)

'' Dim wb As Workbook

' Dim oCon As WorkbookConnection

' For Each oCon In oWb.Connections

' If oCon.Ranges.Count = 0 Then oCon.Delete

' Next oCon

'End Function

''==================================================

Function FnCreatePtInConnection(ByVal oWb As Object, _

ByVal strConName As String)

Dim strShConName As String: strShConName = "Main_Pt"

Dim PTCache As PivotCache

Dim oPt As PivotTable

Dim oSh As Worksheet

'strDataName = "DPU"

'strShPtMainName = "PTmain_" & strDataName

With oWb

' On Error Resume Next

'подготовка листа

FnDeleteSh oWb, strShConName '.Sheets(strShConName).Delete

Set oSh = .Sheets.Add 'Before:=Sheets(1)

With oSh

.Name = strShConName

.Move Before:=Sheets(1)

End With

If oWb.Name = ThisWorkbook.Name Then oSh.Visible = False

'Создание области кэша

Set PTCache = .PivotCaches.Create(SourceType:=xlExternal, SourceData:= _

.Connections(strConName))

'Создание сводной таблицы

With oSh '.Sheets(strShPtMainName)

Set oPt = .PivotTables.Add( _

PivotCache:=PTCache, TableName:=strShConName, _

TableDestination:=oSh.Range("A1"))

End With

Set oPt = Nothing

Set PTCache = Nothing

Set oSh = Nothing

End With

'EventsChange True

'Stop

End Function

'==================================================

'перекидываем кеш (по индексу)

'

Sub test_EditIndexPT()

Dim strShPtMainName As String

Dim strSh_IgnoreName As String

strShPtMainName = ActiveSheet.Name

strSh_IgnoreName = ActiveSheet.Name & " | " & "RppRO"

Call EditIndexPT(strShPtMainName, strSh_IgnoreName)

End Sub

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

Sub EditIndexPT(ByVal strShPtMainName As String, _

ByVal strSh_IgnoreName As String)

Dim oSh As Worksheet

Dim m As Variant, i As Long

Dim oPt As PivotTable

Dim iNbPt As Integer

Dim blnF_Run As Boolean 'флаг обработки листа

Dim dDicShIgnore As Variant, strKey As String

'словарь имен листов в игноре

Set dDicShIgnore = CreateObject("Scripting.Dictionary")

m = Split(strSh_IgnoreName, "|", -1, vbTextCompare)

For i = LBound(m) To UBound(m)

strKey = Trim(m(i))

If Not dDicShIgnore.exists(strKey) Then dDicShIgnore.Add strKey, ""

Next i

'цикл по всем листам

With ThisWorkbook

For Each oSh In .Sheets 'цикл по всем листам книги

If Not dDicShIgnore.exists(oSh.Name) Then 'если имя листа не в списке игнора

If oSh.PivotTables.Count > 0 Then 'то проверяем наличие сводных таблиц

For Each oPt In oSh.PivotTables

With oPt

Debug.Print oSh.Name & " - " & oPt.Name & " - " '& oPt.ColumnRange.Address

'http://www.excelforum.com/l/735371-asdf.html

.CacheIndex = Sheets(strShPtMainName).PivotTables(1).CacheIndex

' .PivotTableWizard SourceType:=xlPivotTable, SourceData:="PTmainDPU"

End With

Next 'oPt

End If

End If

Next 'oSh

End With

End Sub

'==================================================