Sub test()
'Creation TCD
Range("A1").CurrentRegion.Select
ActiveWorkbook.Names.Add Name:="BD", RefersToR1C1:=Selection
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"BD", Version:=xlPivotTableVersion14).CreatePivotTable _
TableDestination:="", TableName:="Pivot_Table_2", _
DefaultVersion:=xlPivotTableVersion14
ActiveWorkbook.ShowPivotTableFieldList = True
With ActiveSheet.PivotTables("Pivot_Table_2").PivotFields( _
"A")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("Pivot_Table_2").PivotFields( _
"B")
.Orientation = xlRowField
.Position = 2
End With
With ActiveSheet.PivotTables("Pivot_Table_2").PivotFields( _
"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").RowAxisLayout 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