Добрый день!
Помогите, пож-та, не могу понять почему макрос не работает в 2010 EXCEL, что нужно заменить, чтобы заработал.
Очень буду благодарна
Sub New_Multi_Table_Pivot()
Dim i As Long
Dim arSQL() As String
Dim objPivotCache As PivotCache
Dim objRS As Object
Dim ResultSheetName As String
Dim SheetsNames As Variant
'имя листа, куда будет выводиться результирующая сводная
ResultSheetName = "Сводная"
'массив имен листов с исходными таблицами
SheetsNames = Array("FAB", "SIG")
'формируем кэш по таблицам с листов из SheetsNames
With ActiveWorkbook
ReDim arSQL(1 To (UBound(SheetsNames) + 1))
For i = LBound(SheetsNames) To UBound(SheetsNames)
arSQL(i + 1) = "SELECT * FROM [" & SheetsNames(i) & "$]"
Next i
Set objRS = CreateObject("ADODB.Recordset")
objRS.Open Join$(arSQL, " UNION ALL "), _
Join$(Array("Provider=Microsoft.Jet.OLEDB.4.0; Data Source=", _
.FullName, ";Extended Properties=""Excel 8.0;"""), vbNullString)
End With
'создаем заново лист для вывода результирующей сводной таблицы
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(ResultSheetName).Delete
Set wsPivot = Worksheets.Add
wsPivot.Name = ResultSheetName
'выводим на этот лист сводную по сформированному кэшу
Set objPivotCache = ActiveWorkbook.PivotCaches.Add(xlExternal)
Set objPivotCache.Recordset = objRS
Set objRS = Nothing
With wsPivot
objPivotCache.CreatePivotTable TableDestination:=wsPivot.Range("A3")
Set objPivotCache = Nothing
Range("A3").Select
End With
End Sub
Помогите, пож-та, не могу понять почему макрос не работает в 2010 EXCEL, что нужно заменить, чтобы заработал.
Очень буду благодарна
Sub New_Multi_Table_Pivot()
Dim i As Long
Dim arSQL() As String
Dim objPivotCache As PivotCache
Dim objRS As Object
Dim ResultSheetName As String
Dim SheetsNames As Variant
'имя листа, куда будет выводиться результирующая сводная
ResultSheetName = "Сводная"
'массив имен листов с исходными таблицами
SheetsNames = Array("FAB", "SIG")
'формируем кэш по таблицам с листов из SheetsNames
With ActiveWorkbook
ReDim arSQL(1 To (UBound(SheetsNames) + 1))
For i = LBound(SheetsNames) To UBound(SheetsNames)
arSQL(i + 1) = "SELECT * FROM [" & SheetsNames(i) & "$]"
Next i
Set objRS = CreateObject("ADODB.Recordset")
objRS.Open Join$(arSQL, " UNION ALL "), _
Join$(Array("Provider=Microsoft.Jet.OLEDB.4.0; Data Source=", _
.FullName, ";Extended Properties=""Excel 8.0;"""), vbNullString)
End With
'создаем заново лист для вывода результирующей сводной таблицы
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(ResultSheetName).Delete
Set wsPivot = Worksheets.Add
wsPivot.Name = ResultSheetName
'выводим на этот лист сводную по сформированному кэшу
Set objPivotCache = ActiveWorkbook.PivotCaches.Add(xlExternal)
Set objPivotCache.Recordset = objRS
Set objRS = Nothing
With wsPivot
objPivotCache.CreatePivotTable TableDestination:=wsPivot.Range("A3")
Set objPivotCache = Nothing
Range("A3").Select
End With
End Sub