XL 2019 Extraire les valeurs de plusieurs plages identiques de plusieurs feuilles différentes

[Atiom]

Bonjour,

Je souhaite extraire les valeurs de deux plages identiques de chaque feuille et les stocker à la suite dans une autre feuille.

J’applique la macro ci-dessous que fonctionne mais je dois modifier pour chaque macro le nom de la feuille et la plage de destination.

Comment faire pour rendre cette opération plus dynamique ?

Si joint un fichier pour une meilleur compréhension.

Merci d’avance pour votre aide

Sub Paul_semaine2()

    Sheets("Synthèse").Select

    Dim SourceFeuille As Worksheet
    Dim DestinationFeuille As Worksheet
    Dim PlageSource As Range
    Dim PlageDestination As Range

    ' Définir les feuilles (remplacez par les noms réels)
    Set SourceFeuille = ThisWorkbook.Sheets("Paul")
    Set DestinationFeuille = ThisWorkbook.Sheets("Synthèse")

    ' Définir la plage à copier
[COLOR=rgb(226, 80, 65)]    [/COLOR][COLOR=rgb(0, 0, 0)]Set PlageSource = SourceFeuille.Range("J5:L46")[/COLOR]

    ' Définir la cellule de départ de la destination [COLOR=rgb(226, 80, 65)]( Décaler chaque fois de 42 lignes )[/COLOR]
   [COLOR=rgb(226, 80, 65)] Set PlageDestination = DestinationFeuille.Range("C47")[/COLOR]

    ' Copier la plage complète (données et format)
[COLOR=rgb(226, 80, 65)]    PlageSource.Copy Destination:=PlageDestination[/COLOR]

 

[sousou]

Bonjour

Ma réponse si c'est cela?

 

[mapomme]

Bonne année à @Atiom,@sousou, @job75 et à tous 😉,

Une simplification des codes.
Les seuls codes se trouvent:
1) dans le module de la feuille de calcul "Synthèse" pour la synthèse:

Sub Synthetiser()
Dim f, i&, lig&
   Application.ScreenUpdating = False  ' plus rapide
   lig = 5                             ' N° de ligne de la première copie
   With Sheets("Synthèse")                                     ' avec la feuille Synthèse
      .Cells(5, "c").Resize(Rows.Count - lig + 1, 3).Clear     ' effacer les précédents résultats
      For Each f In ThisWorkbook.Worksheets                    ' pour chaque feuille de calcul f
         If f.Name <> "Listes" And f.Name <> "Synthèse" Then   ' si le nom de f est diff. de "Listes" et de "Synthèse"
            f.Range("g5:i46").Copy .Cells(lig, "c")            ' on copie la plage à la ligne lig
            lig = .Cells(Rows.Count, "c").End(xlUp).Row + 1    ' N° de ligne de la prochaine copie
            f.Range("j5:L46").Copy .Cells(lig, "c")            ' on copie la plage à la ligne lig
            lig = .Cells(Rows.Count, "c").End(xlUp).Row + 1    ' N° de ligne de la prochaine copie
         End If
      Next f
      lig = .Cells(Rows.Count, "c").End(xlUp).Row              ' N° de la dernière ligne avec valeur
      For i = lig To 5 Step -1                                 ' boucle depuis cette ligne jusqu'à la ligne 5
         If Cells(i, "c") = "" Then Cells(i, "c").Resize(, 3).Delete shift:=xlShiftUp  ' si la cellule colonne C est vide
      Next i                                                                           ' alors on supprime la ligne
   End With
End Sub

2) dans le module de ThisWorkbook pour modifier les noms de feuille:

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
   If Sh.Name <> "Listes" And Sh.Name <> "Synthèse" Then Sh.Name = Sh.Range("H2")
End Sub

 

[job75]

Bonsoir Atiom, sousou,

La macro (affectée au bouton) n'est guère compliquée :

Sub Synthèse()
Dim dest As Range, w As Worksheet, h&
Application.ScreenUpdating = False
Set dest = Sheets("Synthèse").[C5]
dest.CurrentRegion.Clear 'RAZ
For Each w In Sheets(Array("Paul", "Luc", "Maria")) 'liste des feuilles à copier
    w.Range("G5:I46").SpecialCells(xlCellTypeConstants).Copy dest.Offset(h)
    h = dest.CurrentRegion.Rows.Count
    w.Range("J5:L46").SpecialCells(xlCellTypeConstants).Copy dest.Offset(h)
    h = dest.CurrentRegion.Rows.Count
Next
End Sub

Edit : bonsoir mapomme 🙂

A+

 

[job75]

Si dans les plages à copier les lignes de 3 valeurs ne sont pas complètes la macro précédente ne fonctionnera pas.

On utilisera alors cette macro :

Sub Synthèse()
Dim dest As Range, w As Worksheet, h&
Application.ScreenUpdating = False
Set dest = Sheets("Synthèse").[C5]
dest.CurrentRegion.Clear 'RAZ
For Each w In Sheets(Array("Paul", "Luc", "Maria")) 'liste des feuilles à copier
    Intersect(w.Range("G5:I46"), w.Range("G5:I46").SpecialCells(xlCellTypeConstants).EntireRow).Copy dest.Offset(h)
    h = dest.CurrentRegion.Rows.Count
    Intersect(w.Range("J5:L46"), w.Range("J5:L46").SpecialCells(xlCellTypeConstants).EntireRow).Copy dest.Offset(h)
    h = dest.CurrentRegion.Rows.Count
Next
End Sub

Voyez la cellule H10 (aaa) de la feuille "Paul".

 

[Atiom]

Bonjour et encore bonne année à tous,

C'est Super !
Les 3 propositions fonctionnent parfaitement, j'ai le choix !

Un tout grand merci à tous.

Je vous souhaite une excellente jour journée et à bientôt.