Sub Transfert()
Dim LstMois, Mois, LoC As ListObject, TbGlobal(), NbL As Long, Dép As Long, Cpt As Long, i As Long, j As Byte
LstMois = Array("sept", "oct", "nov", "déc", "janv", "févr", "mars", "avr", "mai", "juin")
'Tableau structuré cible
Set LoC = F13_Récap.ListObjects(1)
NbL = 0
'Boucle sur les mois
For Each Mois In LstMois
Infos = ThisWorkbook.Worksheets(Mois).ListObjects(1).DataBodyRange.Value
Dép = NbL: Cpt = UBound(Infos)
NbL =...
Sub Transfert()
Dim LstMois, Mois, LoC As ListObject, TbGlobal(), NbL As Long, Dép As Long, Cpt As Long, i As Long, j As Byte
LstMois = Array("sept", "oct", "nov", "déc", "janv", "févr", "mars", "avr", "mai", "juin")
'Tableau structuré cible
Set LoC = F13_Récap.ListObjects(1)
NbL = 0
'Boucle sur les mois
For Each Mois In LstMois
Infos = ThisWorkbook.Worksheets(Mois).ListObjects(1).DataBodyRange.Value
Dép = NbL: Cpt = UBound(Infos)
NbL = NbL + Cpt
ReDim Preserve TbGlobal(1 To 15, 1 To NbL)
For i = 1 To Cpt
Lgn = Dép + i
TbGlobal(1, Lgn) = Mois
For j = 2 To 15
TbGlobal(j, Lgn) = Infos(i, j - 1)
Next j
Next i
Next Mois
'Effacer le contenu du tableau "Récap"
LoC.Range.Offset(1).Resize(LoC.Range.Rows.Count - 1).ClearContents
'Redimensionner au nouveau nombre de lignes
LoC.Resize LoC.HeaderRowRange.Resize(NbL + 1)
'Charger les données collectées
LoC.DataBodyRange.Value = Application.Transpose(TbGlobal)
End Sub
Private Sub Worksheet_Activate()
Transfert
End Sub
MerciBonsoir à toutes & à tous, bonsoir @Seddiki_adz
J'ai repris ton classeur en utilisant des tableaux structurés, j'ai créé une macro "Transfert" qui est appelée lors de l'activation de la feuille "Récap" :
Enrichi (BBcode):Sub Transfert() Dim LstMois, Mois, LoC As ListObject, TbGlobal(), NbL As Long, Dép As Long, Cpt As Long, i As Long, j As Byte LstMois = Array("sept", "oct", "nov", "déc", "janv", "févr", "mars", "avr", "mai", "juin") 'Tableau structuré cible Set LoC = F13_Récap.ListObjects(1) NbL = 0 'Boucle sur les mois For Each Mois In LstMois Infos = ThisWorkbook.Worksheets(Mois).ListObjects(1).DataBodyRange.Value Dép = NbL: Cpt = UBound(Infos) NbL = NbL + Cpt ReDim Preserve TbGlobal(1 To 15, 1 To NbL) For i = 1 To Cpt Lgn = Dép + i TbGlobal(1, Lgn) = Mois For j = 2 To 15 TbGlobal(j, Lgn) = Infos(i, j - 1) Next j Next i Next Mois 'Effacer le contenu du tableau "Récap" LoC.Range.Offset(1).Resize(LoC.Range.Rows.Count - 1).ClearContents 'Redimensionner au nouveau nombre de lignes LoC.Resize LoC.HeaderRowRange.Resize(NbL + 1) 'Charger les données collectées LoC.DataBodyRange.Value = Application.Transpose(TbGlobal) End Sub
Evénement Activate de la feuille "Récap"
Code:Private Sub Worksheet_Activate() Transfert End Sub
Voir le fichier joint
Amicalement
Alain