Tabela przestawna jest jednym z najpotężniejszych narzędzi w Excelu. Jeżeli mamy plik zawierający wiele pivotów, to możemy napisać makro, które tworzy kompletny spis wszystkich tabel przestawnych.
Obiekt PivotTable
Obiekt PivotTable jest niezwykle bogaty we właściwości. W naszym spisie tabel przestawnych możemy nie tylko odwołać się do ich podstawowych właściwości, ale również pobrać nietypowe informacje jak np. data ostatniego odświeżenia lub nazwa komputera, z którego go dokonano.
Rozbudowany spis pivotów
Kod makra
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 |
Private Const msMODUL As String = "Module1" Option Explicit Public Sub ListaPivotow() '// Makro tworzy listę tabel przestawnych Const sPROC As String = "ListaPivotow" Dim wksArkusz As Worksheet ' Pojedynczy arkusz w pliku Dim pvtPivot As PivotTable ' Obiekt tabeli przestawnej Dim iLicznik As Integer ' Będziemy zwiększać o 1 Dim avPivoty() As Variant ' Wszystkie dane znajdą się w tablicy 'Aktywuj obsługę błędów na starcie 1 On Error GoTo ObslugaBledu 'Pętla po arkuszach w pliku 2 For Each wksArkusz In ThisWorkbook.Worksheets 'Pętla po tabelach przestawnych w pliku 3 For Each pvtPivot In wksArkusz.PivotTables 'Zwięszamy indeks 4 iLicznik = iLicznik + 1 'Zwiększamy rozmiar tablicy 5 ReDim Preserve avPivoty(1 To 7, 1 To iLicznik) 'Zaczytajemy dane do tablicy 6 With pvtPivot 7 avPivoty(1, iLicznik) = .Name 8 avPivoty(2, iLicznik) = .Parent.Name 9 avPivoty(3, iLicznik) = .CacheIndex 10 avPivoty(4, iLicznik) = .SourceData 11 avPivoty(5, iLicznik) = .TableRange2.Address(External:=True) 12 avPivoty(6, iLicznik) = .RefreshDate 13 avPivoty(7, iLicznik) = .RefreshName 14 End With 'With wksListaPivotow 15 Next pvtPivot 'For Each pvtPivot In wksArkusz.PivotTables 16 Next wksArkusz 'For Each wksArkusz In ThisWorkbook.Worksheets 'Zaczytaj do arkusza 17 wksListaPivotow.Range("A2").Resize(iLicznik, 7) = WorksheetFunction.Transpose(avPivoty) Wyjscie: 18 Set wksArkusz = Nothing 19 Set pvtPivot = Nothing 20 On Error GoTo 0 21 Exit Sub ObslugaBledu: 22 Application.ScreenUpdating = True 23 MsgBox "Wystąpił błąd nr " & Err.Number & " (" & Err.Description & ")." _ & vbCr & vbCr & "Linia kodu nr " & Erl & " w procedurze """ & _ sPROC & """ modułu """ & msMODUL & """.", vbInformation, "BŁĄD!" 24 Resume Wyjscie End Sub |
