Bonjour,
Je te renvoie le classeur modifié car le précédent ne fonctionnait pas réellement.
Tu effectueras des tests.
J'ai commenté la procédure pour te permettre de comprendre la démarche. Tu me diras !
ALT F11 pour ouvrir l'éditeur VBE et voir module Feuil1 (Feuil1).
Cdlt.
Option Explicit
Private Sub cmdConsolidate_Click()
'Déclarations des variables
Dim tbl, arr()
Dim rStart As Range, rngGroup As Range
Dim I As Long, J As Long, k As Long
Dim n As Long, x As Double
Dim startDate As Date, endDate As Date
Dim q As Long
Dim startYear As Integer
'Optimisation procédure (gel affichage)
Application.ScreenUpdating = False
'Tableau
tbl = Me.ListObjects("Tableau3").DataBodyRange.Value
With Me.ListObjects("Tableau4")
'RAZ tableau
If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
'Initialisation cellule pour copie
Set rStart = .InsertRowRange.Cells(1)
End With
For I = 1 To UBound(tbl, 1)
'Dates de départ et de fin
startDate = CDate(tbl(I, 1)): endDate = CDate(tbl(I, 2))
'Année de départ
startYear = Year(startDate)
'Trimestre de départ
q = DatePart("q", startDate)
'Nombre de trimestres entre la date de début et la date de fin
n = DateDiff("q", startDate, endDate) + 1
For J = 1 To n
'Mois en fonction du numéro de trimestre
x = Choose(q, 1, 4, 7, 10)
ReDim Preserve arr(3, k + 1)
'Date (année)
arr(0, k) = CLng(DateAdd("q", 1 * J - 1, DateSerial(startYear, x, 1)))
'Numéro du trimestre
arr(1, k) = DatePart("q", arr(0, k))
'Montant
arr(2, k) = tbl(I, 3)
k = k + 1
Next J
Next I
'Restitution des données
rStart.Resize(UBound(arr, 2), 3).Value = Application.Transpose(arr)
With Me.PivotTables(1)
'Actualisation du TCD
.PivotCache.Refresh
'Mise en forme TCD (groupement par trimestres)
With .PivotFields("Année")
.Orientation = xlColumnField
Set rngGroup = .DataRange
On Error Resume Next
rngGroup.Cells(1).Group _
Start:=True, _
End:=True, _
Periods:=Array(False, False, False, False, False, False, True)
'Tri
.PivotFields("Trimestre").AutoSort xlAscending, "Trimestre"
End With
End With
'Mise en forme étiquettes de lignes du TCD
With Me.Columns(11)
.Replace "1", "T1"
.Replace "2", "T2"
.Replace "3", "T3"
.Replace "4", "T4"
End With
'RAZ variables
Erase arr()
Set rngGroup = Nothing: Set rStart = Nothing
End Sub
Private Sub cmdRaz_Click()
Application.ScreenUpdating = False
'RAZ tableau
With Me.ListObjects("Tableau4")
If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
End With
'Actualisation TCD
Me.PivotTables(1).PivotCache.Refresh
End Sub