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
|
Sub test()
'Creation TCD
Range("A1").CurrentRegion.Select
ActiveWorkbook.Names.Add Name:="BD", RefersToR1C1:=Selection
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDa tabase, SourceData:= _
"BD", Version:=xlPivotTableVersion14).CreatePivotTable _
TableDestination:="", TableName:="Pivot_Table_2", _
DefaultVersion:=xlPivotTableVersion14
ActiveWorkbook.ShowPivotTableFieldList = True
With ActiveSheet.PivotTables("Pivot_Table_2").PivotFiel ds( _
"A")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("Pivot_Table_2").PivotFiel ds( _
"B")
.Orientation = xlRowField
.Position = 2
End With
With ActiveSheet.PivotTables("Pivot_Table_2").PivotFiel ds( _
"C")
.Orientation = xlRowField
.Position = 3
End With
'Enelever totaux, sous totaux etc
Dim p As PivotField
For Each p In ActiveSheet.PivotTables(1).PivotFields
If p.Orientation = 1 Then p.Subtotals = Array(False, False, False, False, _
False, False, False, False, False, False, False, False)
Next p
With ActiveSheet.PivotTables("Pivot_Table_2")
.ColumnGrand = False
.RowGrand = False
End With
ActiveSheet.PivotTables("Pivot_Table_2").RowAxisLa yout xlTabularRow
'Activer fusion des cellules identiques
ActiveSheet.PivotTables("Pivot_Table_2").MergeLabels = True
'Conserver format des cellules et ajustement auto
With ActiveSheet.PivotTables("Pivot_Table_2")
.HasAutoFormat = False
.PreserveFormatting = True
End With
End Sub |
Partager