XL 2010 Fusion des cellules identiques d'une partie d'un TCD - macro VBA

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

Cliquez pour agrandir...