Copier des colonnes de différents onglets

Le 24/03/2016 à 22:45

Bonjour,

Je souhaiterai avoir votre aide pour écrire le code VBA permettant de copier des colonnes de différents onglets dans un onglet de synthèse.

J’ai bien lu des posts qui traitaient de cette problématique mais je n’arrive pas à l’appliquer dans mon exemple (simple).

Mon fichier est composé de différents onglets, nommés « Point 1 » , « Point 2 » … « Point 10 ».

Ces onglets, composés de différentes colonnes, sont le résultat de mesures.

Je souhaite que la macro créé un onglet de « Synthese » à l’intérieur duquel la 2ème colonne de chaque point soit copiée.

J’ai mis en PJ un exemple de fichier, pour illustrer la problématique. Le vrai fichier a bien 10 points et plus de 5000 lignes.

J’ai d’abord utilisé l’enregistrement de macro qui m’a donné ce code (mais il n’y évidemment pas de boucle) :

Sub Macro1()
'
' Macro1 Macro
'

'
    Sheets("point1").Select
    Range("C2:C20").Select
    Selection.Copy

    Sheets("RMSD").Select
    Range("B2").Select
    ActiveSheet.Paste

    Sheets("point2").Select
    Range("C2:C20").Select
    Application.CutCopyMode = False
    Selection.Copy

    Sheets("RMSD").Select
    Range("C2").Select
    ActiveSheet.Paste

    Sheets("point3").Select
    Range("C2:C20").Select
    Application.CutCopyMode = False
    Selection.Copy

    Sheets("RMSD").Select
    Range("D2").Select
    ActiveSheet.Paste
End Sub

Puis j’ai trouvé ce bout de code sur le forum que j’ai essayé d’adapter à ma sauce, mais le résultat n’est pas là:

Sub Copiercoller()
Dim OG As Worksheet 'déclare la variable OG (OnGlet)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Application.ScreenUpdating = False 'masque les changements à l'écran

'****************************************************
'récupération des données dans les différents onglets
'****************************************************
For Each OG In Sheets 'boucle sur tous les onglets du classeur
  Select Case Left(OG.Name, 5) 'action en fonction des 5 premières lettres du nom de l'onglet
      Case "point" 'cas "point"
          Set DEST = Sheets("RMSD").Cells(Application.Rows.Count, 2).End(xlUp) 'définit la cellule de destination DEST
            OG.Range("C2:C20").Copy ''copie la plage C2:C4200
            DEST.PasteSpecial (xlPasteValues) 'colle les valeurs de la plage à partir de la colonne D
  End Select 'fin de l'action en fonction de...
Next OG 'prochain onglet de la boucle
Application.CutCopyMode = False 'annule le clignotement lié au copier
Application.ScreenUpdating = True 'affiche les changements à l'écran
End Sub

Tel qu’il est écrit, le code copie la 2ème colonne du « Point1 », mais il ne boucle pas.

Je pense qu’il y a une double incrémentation à faire ; d’une part sur l’onglet et d’autre part sur l’offset…

J’ai également essayé d’utiliser la fonction ‘=INDIRECT("'"&SUBSTITUE(D1;"'";"''")&"'!C2")’ mais je n’ai pas réussi à boucler…

Je vous remercie par avance pour votre aide,

escadron

40macro-test.xlsm (33.34 Ko)

Le 24/03/2016 à 23:28

Bonsoir,

je viens de tester ceci qui donne les résultats que tu souhaites.

Attention, cette macro copie la colonne "C" ! Dans ton fichier-exemple, après comparaison des chiffres affichés, ce sont apparemment ces colonnes-là qui sont copiées dans "Synthese".

S'il faut corriger, tu remplaces "C:C" par "B:B".

Tu copies ce code dans la Feuille "Synthese". Pour démarrer la macro, tu cliques la cellule "A1". Si elle est déjà selectionnée, tu cliques ailleurs et tu reviens vers "A1"

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
If Target.Address = [A1].Address Then
    For x = 1 To ActiveWorkbook.Sheets.Count - 1
        Sheets(x).Range("C:C").Copy Destination:=Worksheets("Synthese").Cells(1, x + 1)
    Next
End If
'
End Sub

A+

Le 25/03/2016 à 16:50

Salut curulis57,

Tout d'abord merci pour ton aide !

C'est effectivement la colonne C qui m'intéresse, j'aurais dû le préciser...

Ton code marche nickel ; j'aurais juste souhaité que la première ligne de l'onglet "Synthese" garde le nom des points "Point1", "Point2", etc. pour plus de visibilité.

C'est pour cela que j'avais essayé d'utiliser la fonction Indirect / Substitute...

Je te remercie pour ton retour,

Cordialement,

escadron

Le 25/03/2016 à 16:56

Bonjour Escadron,

je l'avais remarqué aussi mais trop tard, c'était parti! Trop vite!

Juste un chiffre à changer :

If Target.Address = [A1].Address Then
    For x = 1 To ActiveWorkbook.Sheets.Count - 1
        Sheets(x).Range("C:C").Copy Destination:=Worksheets("Synthese").Cells([color=#FF0000]2[/color], x + 1)
    Next
End If

Bon travail!

A+

Le 25/03/2016 à 17:02

Merci pour ta réactivité curulis57

Malheureusement Excel m'indique une erreur de compilation / syntaxe...

Je ne suis pas familier avec le VBA et n'arrive pas à voir l'erreur.

Le 25/03/2016 à 21:16

J'espère que tu n'as pas copié toutes les balises parasites du post précédent !!!!!

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
If Target.Address = [A1].Address Then
    For x = 1 To ActiveWorkbook.Sheets.Count - 1
        Sheets(x).Range("C:C").Copy Destination:=Worksheets("Synthese").Cells(2, x + 1)
    Next
End If
'
End Sub

C'est juste le "2"!

Copy Destination:=Worksheets("Synthese").Cells(2, x + 1)

qu'il fallait changer pour copier en deuxième ligne!

Chez moi, ça roule!

A+

Le 25/03/2016 à 21:28

Ah ah non je te rassure !

J'ai bien essayé de remplacer par un 2, mais Excel me met une "erreur 1004"

" Le collage ne peut être effectué car les zones Copier et de collage sont de tailles différentes "

Here's the problem

Merci pour ta patience !

Le 25/03/2016 à 22:18

Effectivement! Et j'ai compris pourquoi!

Avec ("C:C"), je sélectionnais la colonne entière pour ensuite essayer de la décaler d'un cran vers le bas... Forcément!!!

Donc,...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
If Target.Address = [A1].Address Then
    For x = 1 To ActiveWorkbook.Sheets.Count - 1
        iFlag = Sheets(x).Range("C" & Rows.Count).End(xlUp).Row
        Sheets(x).Range("C1:C" & iFlag).Copy Destination:=Worksheets("Synthese").Cells(2, x + 1)
    Next
End If
'
End Sub

On apprend tous les jours de ses c... !

Merci à toi!

A+

J'oubliais! Ce code impose, bien entendu, que la feuille "Synthese" soit TOUJOURS la dernière, APRES les Poin1,2,...

A+

Le 28/03/2016 à 17:44

Merci pour ton aide curulis57 !

Je vais garder précieusement ce bout de code, car il pourrait bien m'être utile pour d'autres applications.

A bientôt,

escadron

Le 28/03/2016 à 18:02

Petite question supplémentaire... c'est ça quand on commence à goûter les joies des Macro

Est-il possible d'avoir le nom des onglets à la place de "Real Part" dans les colonnes copiées dans l'onglet Synthese ?

Merci !

Le 28/03/2016 à 18:16

Salut Escadron,

tu peux préciser, stp... car je pense qu'ils y sont déjà en ligne 1 !!

A moins que tu ne désires que ne soient affichés en ligne 1 que les onglets existants ?!?

Il faudrait aussi descendre la colonne A de 1 cran pour faire correspondre les en-têtes!

A te lire.

Le 28/03/2016 à 18:47

Effectivement, dans le fichier transmis j'avais rentré manuellement le nom des onglets en ligne 1 de la feuille Synthese pour expliquer ma problématique.

Mon vrai fichier de travail comprend plus de 20 onglets.

Lorsque je lance ta macro, j'obtiens donc 20 colonnes intitulées "Real Part" dans l'onglet Synthese, ce qui ne facilite pas la lecture / exploitation de ces données.

J'aimerais donc qu'en ligne 1 soient affichés le nom des onglets existants à la place de "Real Part".

Pour simplifier le problème de décalage des lignes, je n'ai plus spécialement besoin de connaitre la Frequency (colonne A).

Le problème revient donc "simplement" à copier les colonnes des différents onglets, dans l'onglet Synthese, en gardant le nom des onglets existants.

Désolé de changer légèrement la problématique

Merci pour ta patience !

Le 28/03/2016 à 19:44

Bonsoir Escadron,

si j'ai bien compris, j'ai supprimé la colonne "Frequency" et les en-têtes "Real part" de SYNTHESE pour ne laisser que les chiffres et les noms des onglets "POINT...".

A remplacer dans POINT1...

'
If Target.Address = [A1].Address Then
    For x = 1 To ActiveWorkbook.Sheets.Count - 1
        Worksheets("Synthese").Cells(1, x) = UCase$(Sheets(x).Name)
        Worksheets("Synthese").Cells(1, x).Interior.ColorIndex = 15
        iFlag = Sheets(x).Range("C" & Rows.Count).End(xlUp).Row
        Sheets(x).Range("C2:C" & iFlag).Copy Destination:=Worksheets("Synthese").Cells(2, x)
    Next
End If
'

J'espère que c'est ce que tu voulais!

A+

Le 28/03/2016 à 20:09

Parfait, c'est exactement ce dont j'ai besoin !

Merci beaucoup curulis57 !

A bientôt

escadron

Le 05/05/2018 à 12:09

Bonjour le forum

J'ai trouvé cette discussion de escadron ci-dessous et le code VBA m'intéresse, je l'ai mis sur un fichier qui à plus de 250 feuilles

dont certaines sont nommés "Opérations 01 jusqu'a Opérations 53 , la il n'y en a que 10 pour alléger le fichier

ça fonctionne mais j'ai un petit souci, j'ai fait deux modules avec le code ci dessous un qui sélectionne les cellule de A6: A30 (numéro O.M "Ordre Maintenance" ) , puis l'autre qui sélectionne les cellules de D6:30 ( "Opération effectués) et les recopie dans la feuille BDD dans les colonnes M et N ( c'est pour le test )

Le souci c'est que ça crée un décalage de lignes entre les deux colonnes et je ne comprends pas pourquoi

J'ai pensé après que ça pouvait venir du nombre de lignes dans chaque onglet "Opérations" qui est differente

est que quelqu'un peut m'aider?

Merci à curulis57 et escadron pour les codes

Cordialement

Papigouzou

escadron a écrit :
Bonjour,
Je souhaiterai avoir votre aide pour écrire le code VBA permettant de copier des colonnes de différents onglets dans un onglet de synthèse.
J’ai bien lu des posts qui traitaient de cette problématique mais je n’arrive pas à l’appliquer dans mon exemple (simple).
Mon fichier est composé de différents onglets, nommés « Point 1 » , « Point 2 » … « Point 10 ».
Ces onglets, composés de différentes colonnes, sont le résultat de mesures.
Je souhaite que la macro créé un onglet de « Synthese » à l’intérieur duquel la 2ème colonne de chaque point soit copiée.
J’ai mis en PJ un exemple de fichier, pour illustrer la problématique. Le vrai fichier a bien 10 points et plus de 5000 lignes.
Sub Copiercoller()
Dim OG As Worksheet 'déclare la variable OG (OnGlet)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Application.ScreenUpdating = False 'masque les changements à l'écran

'****************************************************
'récupération des données dans les différents onglets
'****************************************************
For Each OG In Sheets 'boucle sur tous les onglets du classeur
  Select Case Left(OG.Name, 5) 'action en fonction des 5 premières lettres du nom de l'onglet
      Case "point" 'cas "point"
          Set DEST = Sheets("RMSD").Cells(Application.Rows.Count, 2).End(xlUp) 'définit la cellule de destination DEST
            OG.Range("C2:C20").Copy ''copie la plage C2:C4200
            DEST.PasteSpecial (xlPasteValues) 'colle les valeurs de la plage à partir de la colonne D
  End Select 'fin de l'action en fonction de...
Next OG 'prochain onglet de la boucle
Application.CutCopyMode = False 'annule le clignotement lié au copier
Application.ScreenUpdating = True 'affiche les changements à l'écran
End Sub
Tel qu’il est écrit, le code copie la 2ème colonne du « Point1 », mais il ne boucle pas.
Je pense qu’il y a une double incrémentation à faire ; d’une part sur l’onglet et d’autre part sur l’offset…
J’ai également essayé d’utiliser la fonction ‘=INDIRECT("'"&SUBSTITUE(D1;"'";"''")&"'!C2")’ mais je n’ai pas réussi à boucler…
Je vous remercie par avance pour votre aide,
escadron

Le 05/05/2018 à 12:13

J'ai oublié le fichier

17contrat-de-maintenance-rapport-semestriel-2018.xlsm (542.96 Ko)

Le 05/05/2018 à 13:59

Bonjour papigouzou, escadron,

Salut curulis57

L'instruction suivante:

Set DEST = Sheets("BDD").Cells(Application.Rows.Count, 13).End(xlUp)

définit comme cellule de destination, la dernière cellule non-vide en colonne 13 de ta feuille BDD. Chaque fois que tu fais ton Collage Spécial - Valeurs, tu "écrases" cette dernière cellule (pour 10 feuilles "opération", tu perds donc 10 lignes, au final)

Par ailleurs, tu écris deux procédures différentes pour copier le contenu de la colonne A, puis de la colonne D (au passage, si les colonnes A, B & C de tes feuilles "opération" n'étaient pas fusionnées, tu te serais simplifié la tâche !)

Sur un volume tel que tu l'annonces (250 feuilles ) le code initial récupéré par escadron pourrait "ramer" (un peu, beaucoup, passionnément, ...)

Avec le fichier que tu as transmis (10 feuilles opérations) le code suivant copie -dans la même procédure- les deux colonnes, en M et N. Les données résultantes semblent correspondre à tes actuelles colonnes B et C

Sub Copiercoller()
Dim OG As Worksheet 'déclare la variable OG (OnGlet)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Application.ScreenUpdating = False 'masque les changements à l'écran

'****************************************************
'récupération des données dans les différents onglets
'****************************************************
For Each OG In Sheets 'boucle sur tous les onglets du classeur
    Select Case Left(OG.Name, 5) 'action en fonction des 5 premières lettres du nom de l'onglet
        Case "Opéra" 'case "Opéra"
            Set DEST = Sheets("BDD").Cells(Application.Rows.Count, 13).End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
            derligne = OG.Cells(Rows.Count, 1).End(xlUp).Row 'denière cellule non-vide en col A de la feuille "opérations"
            OG.Range("A6:A" & derligne).Copy 'copie la plage A6:Axx (et pas sytématiquement A6:A34)
            DEST.PasteSpecial (xlPasteValues) 'colle les valeurs de la plage à partir de la colonne A
            OG.Range("D6:D" & derligne).Copy 'copie la plage D6:Dxx
            DEST.Offset(0, 1).PasteSpecial (xlPasteValues) 'colle les valeurs de la plage à partir de la colonne D
    End Select 'fin de l'action en fonction de...
Next OG 'prochain onglet de la boucle
Application.CutCopyMode = False 'annule le clignotement lié au copier
Application.ScreenUpdating = True 'affiche les changements à l'écran
End Sub

Le 05/05/2018 à 15:20

Salut escadron, U.Milité,

même chose en jouant avec des tableaux et un petit bouton rouge...

Private Sub cmdGO_Click()
'
Dim sWk As Worksheet
Dim tDataA, tDataD, tDataAF
Dim iRow As Integer, iRow1 As Integer
'
Application.ScreenUpdating = False
iRow = Range("M" & Rows.Count).End(xlUp).Row
If iRow > 1 Then Range("L2:O" & iRow).ClearContents
'
For Each sWk In Sheets
If Left(sWk.Name, 5) = "Opéra" Then
iRow = Range("M" & Rows.Count).End(xlUp).Row
iRow1 = sWk.Range("A" & Rows.Count).End(xlUp).Row
tDataA = sWk.Range("A6:A" & iRow1).Value
tDataD = sWk.Range("D6:D" & iRow1).Value
tDataAF = sWk.Range("AF6:AF" & iRow1).Value
iRow1 = iRow + UBound(tDataA, 1)
Range("L" & iRow + 1 & ":L" & iRow1).Value = sWk.[B3]
Range("M" & iRow + 1 & ":M" & iRow1).Value = tDataA
Range("N" & iRow + 1 & ":N" & iRow1).Value = tDataD
Range("O" & iRow + 1 & ":O" & iRow1).Value = tDataAF
End If
Next
Application.ScreenUpdating = True
'
End Sub

A+

19contrat-de-maintenance-rapport-semestriel-2018.xlsm (533.31 Ko)

Le 05/05/2018 à 22:17

Bonjour,

U.Milité, et Curulis57

U. Milité a écrit :
Bonjour papigouzou, escadron,
Salut curulis57
L'instruction suivante:
Set DEST = Sheets("BDD").Cells(Application.Rows.Count, 13).End(xlUp)
définit comme cellule de destination, la dernière cellule non-vide en colonne 13 de ta feuille BDD. Chaque fois que tu fais ton Collage Spécial - Valeurs, tu "écrases" cette dernière cellule (pour 10 feuilles "opération", tu perds donc 10 lignes, au final)
Par ailleurs, tu écris deux procédures différentes pour copier le contenu de la colonne A, puis de la colonne D (au passage, si les colonnes A, B & C de tes feuilles "opération" n'étaient pas fusionnées, tu te serais simplifié la tâche !)
Sur un volume tel que tu l'annonces (250 feuilles ) le code initial récupéré par escadron pourrait "ramer" (un peu, beaucoup, passionnément, ...)
J'ai fourni un fichier allégé car avec les 250 feuilles le fichier était trop lourd, par contre j'ai essayé le code de Curulis57 dans le fichier est ça n'a pas eu l'air de ramer
Avec le fichier que tu as transmis (10 feuilles opérations) le code suivant copie -dans la même procédure- les deux colonnes, en M et N. Les données résultantes semblent correspondre à tes actuelles colonnes B et C
Les colonnes M et N n'étaient la que pour le test je n'ai pas voulu modifier le fichier , il appartient à mon responsable.Je vais tester les deux codes que vous m'avez fourni .
Cordialement
Sub Copiercoller()
Dim OG As Worksheet 'déclare la variable OG (OnGlet)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Application.ScreenUpdating = False 'masque les changements à l'écran

'****************************************************
'récupération des données dans les différents onglets
'****************************************************
For Each OG In Sheets 'boucle sur tous les onglets du classeur
    Select Case Left(OG.Name, 5) 'action en fonction des 5 premières lettres du nom de l'onglet
        Case "Opéra" 'case "Opéra"
            Set DEST = Sheets("BDD").Cells(Application.Rows.Count, 13).End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
            derligne = OG.Cells(Rows.Count, 1).End(xlUp).Row 'denière cellule non-vide en col A de la feuille "opérations"
            OG.Range("A6:A" & derligne).Copy 'copie la plage A6:Axx (et pas sytématiquement A6:A34)
            DEST.PasteSpecial (xlPasteValues) 'colle les valeurs de la plage à partir de la colonne A
            OG.Range("D6:D" & derligne).Copy 'copie la plage D6:Dxx
            DEST.Offset(0, 1).PasteSpecial (xlPasteValues) 'colle les valeurs de la plage à partir de la colonne D
    End Select 'fin de l'action en fonction de...
Next OG 'prochain onglet de la boucle
Application.CutCopyMode = False 'annule le clignotement lié au copier
Application.ScreenUpdating = True 'affiche les changements à l'écran
End Sub

Le 05/05/2018 à 22:34

Curulis57

je viens de tester ton code et il créé un blocage à la ligne surlignée

Private Sub cmdGO_Click()

Dim sWk As Worksheet

Dim tDataA, tDataD, tDataAF

Dim iRow As Integer, iRow1 As Integer

Application.ScreenUpdating = False

iRow = Range("M" & Rows.Count).End(xlUp).Row

If iRow > 1 Then Range("L2:O" & iRow).ClearContents

For Each sWk In Sheets

If Left(sWk.Name, 5) = "Opéra" Then

iRow = Range("M" & Rows.Count).End(xlUp).Row

iRow1 = sWk.Range("A" & Rows.Count).End(xlUp).Row

tDataA = sWk.Range("A6:A" & iRow1).Value

tDataD = sWk.Range("D6:D" & iRow1).Value

tDataAF = sWk.Range("AF6:AF" & iRow1).Value

iRow1 = iRow + UBound(tDataA, 1)

Range("L" & iRow + 1 & ":L" & iRow1).Value = sWk.[B3]

Range("M" & iRow + 1 & ":M" & iRow1).Value = tDataA

Range("N" & iRow + 1 & ":N" & iRow1).Value = tDataD

Range("O" & iRow + 1 & ":O" & iRow1).Value = tDataAF

End If

Application.ScreenUpdating = True

End Sub

Cdlt, Papigouzou

Rechercher des sujets similaires à "copier colonnes differents onglets"