XL 2016 code de transfert

Seddiki_adz

XLDnaute Impliqué
Bonsoir
je lance a tous les experts de m'aider a trouver un code pour transfert les donnée des onglets sep ; oct ; nov ;..., juin vers l'onglet feuil2
Merci d'avance
 

Pièces jointes

  • dimanche.xlsx
    68.8 KB · Affichages: 14
Solution
Bonsoir à 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 =...

AtTheOne

XLDnaute Impliqué
Supporter XLD
Bonsoir à 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
 

Pièces jointes

  • code de transfert.xlsm
    71.8 KB · Affichages: 5

Seddiki_adz

XLDnaute Impliqué
Bonsoir à 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
Merci
 

Statistiques des forums

Discussions
299 930
Messages
1 980 159
Membres
207 010
dernier inscrit
Setry