Copier Coller plage de différent onglets en une seule avec bouton
Bonjour Mesdames, Bonjour Messieurs,
J'ai le fichier ci joint qui contient plusieurs feuilles:
- 6 extractions, chacune avec dans sa feuille : E1, E2,..., E6
- 2 feuilles de données complémentaires : "Liste" et "Compléments"
- 1 feuilles devant rassembler les 6 extractions croisé (par formules) avec les données complémentaires : "Extraction Globale"
- 1 feuille avec une bouton: "Test"
Je sais que la question à déjà été posée, mais mon auto-formation ayant commencer depuis seulement 3 jours le temps me manque pour ce que je souhaite faire...
J'aimerais donc que les données de chaque extraction soit copier coller sur la feuille "Extraction Globale" à la suite les unes des autres (A2 pour la première), après qu'une suppression des lignes 2 à xxx à été faite sur cette même feuille
J'ai réussi à faire la suppression avec le code suivant:
Sub Robert()
Dim ws As Worksheet,
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Extraction Globale" Then
ws.Rows("3:1048576").Delete Shift:=xlUp
End If
Next ws
End Sub
Mais je n'arrive pas à faire la copier coller des autres onglets... Ma dernière tentative ressemble à cela:
Sub robert()
Dim ws As Worksheet, derlig As Long
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Extraction Globale" Then
ws.Rows("3:1048576").Delete Shift:=xlUp
End If
If ws.Name <> "Liste" And ws.Name <> "test" And ws.Name <> "Extraction Globale" And ws.Name <> "Compléments" Then
derlig = Range("A65536").End(xlUp).Row
'je colore et utilise .Select juste pour voir le cheminement de la macro à terme ils disparaitrons
Range(Cells(2, 1), Cells(derlig, 23)).Select
With Selection.Interior
.Color = 65535
End With
End If
Next ws
End Sub
Par conséquent, une âme charitable peut elle m'aider à corriger ce code immonde qui est le mien
Un grand merci par avance pour vos retours
Bonjour JKennedy !
Voici le code qui te permet de rassembler toute tes feuilles E1 // E2 etc... sur ta feuille Extraction Globale en ayant au préalable, remis le tableau à blanc :
Sub CopieColle()
Dim x As Long, y As Long
x = Sheets(9).Range("A" & Rows.Count).End(xlUp).Row
If x > 2 Then
Sheets(9).Rows("2:" & x).Delete
End If
For y = 3 To 8
x = Sheets(y).Range("A" & Rows.Count).End(xlUp).Row
Sheets(y).Range("A2:W" & x).Copy
x = Sheets(9).Range("A" & Rows.Count).End(xlUp).Row
Sheets(9).Range("A" & x).PasteSpecial
Next
End Sub
Par contre je n'ai pas compris ce que tu voulais faire avec ta feuille "Compléments" :/
WAAAAAA ! C'est magnifique *.* Un immense merci
Aurais tu l'amabilité de m'expliquer comment ça fonctionne ? Parce que par exemple si je rajoute des feuilles qui ne doivent pas être concerné par le copier coller elle serons ignorées par ta macro?
Pour la feuille compléments, elle me sert juste à remplir les 4 dernières colonne du tableau. L'organisation de mon entreprise étant PA-RF-AI-TE, il me faut 2/3 extractions différentes pour avoir toutes les données souhaitées...
Aurais tu l'amabilité de m'expliquer comment ça fonctionne ?
C'est partie pour des explications, ligne par ligne ;D !
Dim x As Long, y As Long
Ici je déclare mes variables "x" et "y"
x = Sheets(9).Range("A" & Rows.Count).End(xlUp).Row
Ici je compte le nombre de ligne de ma feuille numéro 9, qui correspond dans ton classeur à la feuille "Extraction Globale"
C'est à dire, que ta feuille numéro 1 est la feuille la plus à gauche de ton classeur, puis la numéro 2 est celle qui viens juste après. Tu continue jusqu’à arriver à la feuille qui t’intéresse !
If x > 2 Then
Sheets(9).Rows("2:" & x).Delete
End If
Si mon nombre de ligne est supérieur à deux, alors je supprime les lignes 2 à x (qui est égal au nombre de ligne calculé dans la ligne au dessus)
For y = 3 To 8
x = Sheets(y).Range("A" & Rows.Count).End(xlUp).Row
Sheets(y).Range("A2:W" & x).Copy
x = Sheets(9).Range("A" & Rows.Count).End(xlUp).Row
Sheets(9).Range("A" & x).PasteSpecial
Next
Le For
créé une boucle dans ta macro. C'est à dire que tout ce qui va se trouver entre ton For
et ton Next
va se répéter tant que la condition n'est pas remplie.
Ici notre condition c'est que notre variable "y" commence avec la valeur 3, et doit atteindre 8 pour arrêter la boucle !
Et l'action à répéter est de compter le nombre de ligne dans la feuille numéro "y" et de copier celle-ci
Sheets(y).Range("A2:W" & x).Copy
puis d'aller en feuille 9 et de les coller
Sheets(9).Range("A" & x).PasteSpecial
à la première ligne vide trouver grâce à
x = Sheets(9).Range("A" & Rows.Count).End(xlUp).Row
!
A chaque fois qu'on arrive au Next
, y prend automatiquement une valeur supplémentaire, et on boucle
Et voilà tu a ton copier // coller
Parce que par exemple si je rajoute des feuilles qui ne doivent pas être concerné par le copier coller elle serons ignorées par ta macro?
En effet, si tu rajoute des feuilles tu devra changer les numéros de feuilles indiquées dans ce code :p
Pour la feuille compléments, elle me sert juste à remplir les 4 dernières colonne du tableau
Et du coup j'ai un truc à faire avec sa ou c'est bon :0 ?
Alors déjà j'ai absolument tout compris du premier coup et ça c'est un exploit !
Un très grand merci pour tes explications ultra clair ! je me mets le lien en Favoris ça me resservira !
Pour les feuilles que je rajouterais je m'arrangerais pour les mettre après histoire de ne pas tout casser x)
Et pour les 4 dernières colonne tu n'a rien faire avec ! Tu en as déjà suffisamment fait
encore un immense merci à toi !!!
sujet résolu ^.^
Désolé pour le double poste mais
AAAAAAAH J'ai trouvé une erreur ! Je sais pas pourquoi mais le copier coller se fait toujours sur la dernière ligne du copier coller précédent ! Help Me !
Sauf que si je fait
Sub CopieColle()
Dim x As Long, y As Long
x = Sheets(9).Range("A" & Rows.Count).End(xlUp).Row
If x > 2 Then
Sheets(9).Rows("2:" & x).Delete
End If
For y = 3 To 8
x = Sheets(y).Range("A" & Rows.Count).End(xlUp).Row
Sheets(y).Range("A2:W" & x).Copy
x = Sheets(9).Range("A" & Rows.Count).End(xlUp).Row
Sheets(9).Range("A" & x + 1).PasteSpecial
Next
End Sub
Qui me paraissait être une bonne idée, cela m'efface totalement la ligne 2 et me colle tout en ligne 3... Par contre les copier coller ne se superposent plus
Mea Culpa
Sa marchera mieux comme sa :
Sub CopieColle()
Dim x As Long, y As Long, z As Long
x = Sheets(9).Range("A" & Rows.Count).End(xlUp).Row
If x > 2 Then
Sheets(9).Rows("2:" & x).Delete
End If
For y = 3 To 8
x = Sheets(y).Range("A" & Rows.Count).End(xlUp).Row
Sheets(y).Range("A2:W" & x).Copy
z = Sheets(9).Range("A" & Rows.Count).End(xlUp).Row
If z < 2 Then
x = Sheets(9).Range("A" & Rows.Count).End(xlUp).Row + 1
Else
x = Sheets(9).Range("A" & Rows.Count).End(xlUp).Row
End If
Sheets(9).Range("A" & x).PasteSpecial
Next
End Sub
Rebonjour Juice !
Encore merci pour tes réponses rapide et efficace. Malheureusement ta solution ne fonctionne pas
Je cherche aussi de mon coté (Si je trouve une solution c'est que j'ai été touché par un miracle)
EDIT
Le miracle à eu lieu ! J'ai trouvé une solution pas très orthodoxe à mon avis mais elle fonctionne ! J'en suis tout ému
Sub CopieColle()
Dim x As Long, y As Long, z As Long
x = Sheets(9).Range("A" & Rows.Count).End(xlUp).Row
If x > 2 Then
Sheets(9).Rows("2:" & x).Delete
End If
For y = 3 To 8
x = Sheets(y).Range("A" & Rows.Count).End(xlUp).Row
Sheets(y).Range("A2:W" & x).Copy
z = Sheets(9).Range("A" & Rows.Count).End(xlUp).Row
If z < 2 Then
x = Sheets(9).Range("A" & Rows.Count).End(xlUp).Row + 1
Else
x = Sheets(9).Range("A" & Rows.Count).End(xlUp).Row
End If
If y = 3 Then
Sheets(9).Range("A" & x).PasteSpecial
End If
If y >= 4 Then
Sheets(9).Range("A" & x + 1).PasteSpecial
End If
Next
End Sub
En tout cas un grand merci Juice je serais encore en train de galérer sans ton aide et tes explications x)