MyTetra Share
Делитесь знаниями!
построение настраиваемой сводной таблицы с нуля с помощью VBA
16.03.2019
23:43
Раздел: !Закладки - VBA - Сводные

'построение настраиваемой сводной таблицы с нуля с помощью VBA

'это всего лишь пример, поэтому он подходит только для справки при построении пользовательской сводной таблицы


Option Explicit



Sub comparableIR()



Application.ScreenUpdating = False






'building a custom pivot table from scratch using VBA



'this is just an example, so it is only good for reference when building a custom pivot table






Dim pvttbl As PivotTable



Dim wsdata As Worksheet



Dim rngdata As range



Dim pvtcache As PivotCache



Dim wspvt As Worksheet



Dim pvtfld As PivotField






Dim besheet As String









Application.DisplayAlerts = False



On Error Resume Next



ThisWorkbook.Sheets("Comparable Item Report").Delete



On Error GoTo 0



Application.DisplayAlerts = True









'implement error checking capabilities






If Not Sheets("Sheet1").range("V1") = "Class" And Sheets("Sheet1").range("U1") = "ComponentItem Description" Then






MsgBox ("Error: Invalid Data")






Else






besheet = "backend"



Sheets("Sheet1").Copy After:=Sheets("Sheet1")



ActiveSheet.Name = besheet



Worksheets("backend").Activate






'backend processing



Cells(1, 20) = "Item Number"



Cells(1, 21) = "Description"



Cells(1, 22) = "Class"



Cells(1, 26) = "Size"



Cells(1, 24) = "Fee"






Worksheets.Add().Name = "Custom Report"






Set wsdata = Worksheets("backend")



Set wspvt = Worksheets("Custom Report")






wspvt.Activate






For Each pvttbl In wspvt.PivotTables



If MsgBox("Delete existing Pivot Table", vbYesNo) = vbYes Then



pvttbl.TableRange2.Clear



End If



Next pvttbl






Set rngdata = wsdata.range("A:Z")






ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngdata, Version:=xlPivotTableVersion12). _



CreatePivotTable TableDestination:=wspvt.range("A2"), TableName:="PivotTable1", DefaultVersion:=xlPivotTableVersion12






Set pvttbl = wspvt.PivotTables("PivotTable1")






pvttbl.ManualUpdate = True









With pvttbl.PivotFields("Class")



.Orientation = xlRowField



.Position = 1



End With






With pvttbl.PivotFields("Description")



.Orientation = xlRowField



.Position = 2



End With






With pvttbl.PivotFields("Item Number")



.Orientation = xlRowField



.Position = 3



End With






With pvttbl.PivotFields("Size")



.Orientation = xlRowField



.Position = 4



End With






With pvttbl.PivotFields("Fee")



.Orientation = xlRowField



.Position = 5



End With






With Worksheets("Comparable Item Report")



.range("A2").PivotTable.InGridDropZones = True



.range("A2").PivotTable.RowAxisLayout xlTabularRow



.Columns("A:D").AutoFit



End With






With pvttbl



For Each pvtfld In .PivotFields



pvtfld.Subtotals(1) = True



pvtfld.Subtotals(1) = False



Next pvtfld



End With









pvttbl.ManualUpdate = False






Application.DisplayAlerts = False



Sheets("backend").Delete



Application.DisplayAlerts = True









range("F:K").EntireColumn.Hidden = True






range("A1").Value = "Last Run Date: " & Now



With range("A1").Font



.ColorIndex = 1



.Bold = True



End With






Application.ScreenUpdating = True



Rows("4:4").Select



ActiveWindow.FreezePanes = True






Columns("B:B").columnwidth = 40



'Columns("A:W").AutoFit



'range("A:W").wraptext = True






End If






'write some instructions on utilizing pivot table





End Sub

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