Compiler plusieurs onglets en VBA

[eud078]

Bonjour,
Débutant en VBA, et après des recherches sur ce forum, je bloque. Mon objectif: compiler plusieurs onglets dans un seul, en collant quelques colonnes de mon fichier source, les une en dessous des autres. Mes onglets "source" ne comportent pas tous le même nombre de colonnes à copier.
Je joins un fichier exemple, avec 2 onglets Source que je voudrais coller dans l'onglet Compil, cela fonctionne pour le 1er acteur, mais ensuite cela copie sur les données existantes. L'onglet "Attendu" est le résultat que je souhaite avoir quand la macro fonctionnera.
Est-il possible de faire une boucle pour ce type de copier coller.
Merci d'avance pour votre aide.
Bonne journée.

 

[pierrejean]

Bonjour
A tester

 

[eud078]

Bonjour,

Merci PierreJean pour ton aide, mais cela ne copie que les données de l'onglet "Attendu", (qui est le résultat que je voudrais avoir). Je vais regarder ton code et voir si je suis capable de l'adapter.
Cordialement

 

[pierrejean]

Re
Supprime la feuille Attendu et exécute la macro

 

[eud078]

Bonjour

Merci PierreJean, j'ai reussi à faire ce que je voulais.
Voici le Code

'Declaration des variables
Dim Sv As String, Ev As String
Dim DerniereLigne As Integer
Dim PremiereLigneVide As Integer
Dim SvPds As Integer, SvObj As Integer
Dim h As Integer, b As Integer, n As Integer
Dim F As Worksheet, NbBoucles As Integer, DEST As Worksheet


Sub EffaceDonnees()
Worksheets("Export pour repartition segment").Visible = True
Worksheets("Export pour repartition segment").Select
Rows("2:1000000").Clear
Range("a2").Select

End Sub

Sub Consolidation()

Load Message
Message.Show vbModeless
Message.Repaint

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
EffaceDonnees

'Variables
'===========
h = 8 'Premiere ligne à copier
b = 67  'Derniere ligne à copier
n = b - h ' Nombre de lignes à copier
'==========================================================
'==========================================================

For Each F In Sheets
    If F.Name Like "Répartition EV*" Then
  
        SvPds = 9 'Numero de colonne du 1er PDS
      '  SvObj = SvPds + 6 'Numéro de colonne du 1er Objectif
        NbBoucles = F.Range("f1").Value ' Nb de Ptf de l'équipe traitée

                
        For SvPds = 9 To ((NbBoucles * 7) + 2) Step 7
         Set DEST = Worksheets("Export pour repartition segment")
        DerniereLigne = DEST.Cells(Rows.Count, 1).End(xlUp).Row + 1

                    'Copie famille
                    
                    Range(F.Cells(h, 3), F.Cells(b, 3)).Copy
                        ExpoRepSeg.Cells(DerniereLigne, 2).PasteSpecial _
                            Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    
                    'Copie PTF
                    
                    Sv = F.Cells(2, SvPds).Copy
                    ExpoRepSeg.Range("A" & DerniereLigne & ":A" & DerniereLigne + n).PasteSpecial xlPasteValues
                    
                    'Copie PDS
                    
                    Range(F.Cells(h, SvPds), F.Cells(b, SvPds)).Copy
                    ExpoRepSeg.Range("D" & DerniereLigne).PasteSpecial _
                        Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                       
                    'Copie Objectif
                     
                    Range(F.Cells(h, SvPds + 6), F.Cells(b, SvPds + 6)).Copy
                    ExpoRepSeg.Range("C" & DerniereLigne).PasteSpecial _
                        Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Next SvPds
  
  
        End If
Next

 ExpoRepSeg.Rows(DerniereLigne + n + 1 & ":1000000").Select
    Selection.Delete Shift:=xlUp
    
With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
Sheets("Export pour repartition segment").Visible = False
Sheets("Répartition Segment").Activate
Msgbox ("La mise à jour est terminée")
Unload Message

    End Sub