MyTetra Share
Делитесь знаниями!
Создание сводной из внешнего источника(m_Pt)
28.11.2017
11:21
Текстовые метки: m_Pt, Pt, Pivot, Connections, m_PT_Create
Раздел: VBA - Сводные

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 '"I:\0ru_di\Peinture\TPM\07_QUALITE_PEINT\11\Анкур _автоматическая версия\_v"

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


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

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

'

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

Function FnIditIndexPT(ByVal strShPtMainName As String, _

ByVal arShPtName As Variant)

Dim oPt As PivotTable

Dim iNbPt As Integer

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

'Set PT = ThisWorkbook.Sheets("PTmain_DPU").PivotTables(1)

'FF = PT.CacheIndex

With ThisWorkbook

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

' blnF_Run

' если имя листа в списке

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

If oSh.Name Like "*" & arShPtName(i) & "*" Then

blnF_Run = True

GoTo MF_Run:

End If

Next

MF_Run:

If blnF_Run Then 'если имя листа отсутствует в списке исключения

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

For Each oPt In oSh.PivotTables

With oPt

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

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


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