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

Atiom · Jeudi à 16:26

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

VB:

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 · Jeudi à 17:34

Bonjour

Ma réponse si c'est cela?

mapomme · Jeudi à 19:30

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:

VB:

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:

VB:

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 · Jeudi à 19:32

Bonsoir Atiom, sousou,

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

VB:

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 · Jeudi à 20:16

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 :

VB:

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 · Vendredi à 09:19

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.

Atiom · Vendredi à 18:42

Re,

Comment peut-on faire pour copier uniquement les valeurs sans la mise en forme dans code de mapomme ?

J'essayé d'ajouter .Value après Range, mais cela ne marche pas !

Code:

f.Range.Value("g5:i46").Copy .Cells(lig, "c")            ' on copie la plage à la ligne lig

Code:

  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

Merci

job75 · Vendredi à 18:58

Bonsoir,

Atiom à dit:
Comment peut-on faire pour copier uniquement les valeurs sans la mise en forme

Avec la solution de mon post #5 :

VB:

Sub Synthèse()
Dim dest As Range, w As Worksheet, h&
Application.ScreenUpdating = False
Set dest = Sheets("Synthèse").[C5]
dest.CurrentRegion.ClearContents '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).PasteSpecial xlPasteValues 'collage spécial-valeurs
    h = dest.CurrentRegion.Rows.Count
    Intersect(w.Range("J5:L46"), w.Range("J5:L46").SpecialCells(xlCellTypeConstants).EntireRow).Copy
    dest.Offset(h).PasteSpecial xlPasteValues 'collage spécial-valeurs
    h = dest.CurrentRegion.Rows.Count
Next
Application.CutCopyMode = 0
End Sub

A+

Atiom · Vendredi à 19:19

Bonsoir job75
Ok, Parfait!
Je voulais adapter le code de mapomme pour autre chose et croyais qu'il suffisait d'ajouter .Value,
Mais je vais faire avec ta solution,
Encore grand Merci et belle fin de journée.

mapomme · Vendredi à 23:58

Bonsoir @Atiom, à tous, 😉

Atiom à dit:
Comment peut-on faire pour copier uniquement les valeurs sans la mise en forme dans code de @mapomme ?

On peut décomposer le copier et le coller en deux instructions:
1) D'abord un copier de la plage :
f.Range("g5:i46").Copy ' on copie la 1ère plage
2) Puis un collage spécial en valeur et en format de nombre :
.Cells(lig, "c").PasteSpecial xlPasteValuesAndNumberFormats ' on colle les valeurs et formats de nombre

Si on ne veut strictement que les valeurs, on remplacera xlPasteValuesAndNumberFormats par xlPasteValues

Soit le code :

VB:

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                             ' on copie la 1ère plage
            .Cells(lig, "c").PasteSpecial xlPasteValuesAndNumberFormats    ' on colle les valeurs et formats de nombre
            lig = .Cells(Rows.Count, "c").End(xlUp).Row + 1    ' N° de ligne de la prochaine copie
            f.Range("j5:L46").Copy                             ' on copie la 2ème plage
            .Cells(lig, "c").PasteSpecial xlPasteValuesAndNumberFormats    ' on colle les valeurs et formats de nombre
            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 ligner 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  ' la cellule colonne C est vide
      Next i                                                                           ' on supprime la ligne
   End With
End Sub

Atiom · Hier à 07:33

Bonjour mapomme,

Ok, c'est parfait.
Merci pour les infos, pas si simple comme je le croyez!
Bonne journée et à bientôt.

job75 · Hier à 09:26

Bonjour le forum,

Avec la solution de mapomme pas besoin de collage spécial :

VB:

            .Cells(lig, "c").Resize(42, 3) = f.Range("g5:i46").Value   ' on copie la plage en valeurs à la ligne lig
            lig = .Cells(Rows.Count, "c").End(xlUp).Row + 1    ' N° de ligne de la prochaine copie
            .Cells(lig, "c").Resize(42, 3) = f.Range("j5:L46").Value   ' on copie la plage en valeurs à la ligne lig
            lig = .Cells(Rows.Count, "c").End(xlUp).Row + 1    ' N° de ligne de la prochaine copie

A+

mapomme · Hier à 10:46

Bonjour @job75 👍

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

Atiom

XLDnaute Occasionnel

Pièces jointes

sousou

XLDnaute Barbatruc

Pièces jointes

mapomme

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

Atiom

XLDnaute Occasionnel

Atiom

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

Atiom

XLDnaute Occasionnel

mapomme

XLDnaute Barbatruc

Pièces jointes

Atiom

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

mapomme

XLDnaute Barbatruc

Discussions similaires

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

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency