Macro qui ajoute nom onglet

Le 23/04/2020 à 11:13

Bonjour à tous,

Je suis en train de faire une petite macro qui copie colle des tableaux qui sont sur différent onglets, sur un seul et même onglet, les uns à la suite des autres :

Sub TableauMensuel()
Application.ScreenUpdating = False
Dim x As Long, y As Long, z As Long
x = Sheets(13).Range("B" & Rows.Count).End(xlUp).Row
If x > 2 Then
    Sheets(13).Rows("2:" & x).Delete
End If

For y = 1 To 12
    x = Sheets(y).Range("B" & Rows.Count).End(xlUp).Row
    Sheets(y).Range("A2:J" & x).Copy

    z = Sheets(13).Range("B" & Rows.Count).End(xlUp).Row
    If z < 2 Then
        x = Sheets(13).Range("B" & Rows.Count).End(xlUp).Row + 1
    Else
        x = Sheets(13).Range("B" & Rows.Count).End(xlUp).Row
    End If

    If y >= 1 Then
    Sheets(13).Range("A" & x + 1).PasteSpecial
    End If
Next
End Sub

Ce code fonctionne très bien, mais j'aimerais qu'à chaque lignes collées, la provenance de l'onglet d'origine apparaisse en bout de ligne, et c'est la que le bas blesse… Je n'arrive pas à trouver un code qui fonctionne…

J'en appel donc à votre aide,

Merci d'avance pour vos retours,

18classeur1.xlsm (46.67 Ko)
Le 23/04/2020 à 11:29

Bonjour,

La difficulté que je rencontre est que tu utilises x à la fois pour la feuille d'origine et de destination.

J'ai donc défini xy et ajouté cette ligne à tester

        Sheets(13).Range("K" & x + 1 & ":K" & x + xy) = Sheets(y).Name

Essai ceci ...

Sub TableauMensuel()
Application.ScreenUpdating = False
Dim x As Long, y As Long, z As Long, xy As Long
x = Sheets(13).Range("B" & Rows.Count).End(xlUp).Row
If x > 2 Then
    Sheets(13).Rows("3:" & x).Delete
End If

For y = 1 To 12
    xy = Sheets(y).Range("B" & Rows.Count).End(xlUp).Row
    Sheets(y).Range("A2:J" & xy).Copy

    z = Sheets(13).Range("B" & Rows.Count).End(xlUp).Row
    If z < 2 Then
        x = Sheets(13).Range("B" & Rows.Count).End(xlUp).Row + 1
    Else
        x = Sheets(13).Range("B" & Rows.Count).End(xlUp).Row
    End If

    If y >= 1 Then
        Sheets(13).Range("A" & x + 1).PasteSpecial
        Sheets(13).Range("K" & x + 1 & ":K" & x + xy) = Sheets(y).Name
    End If
Next
End Sub

je n'ai pas testé, il faudra probablement ajuster la taille ... par exemple Range("K" & x + 1 & ":K" & x + xy - 1)

Le 23/04/2020 à 11:36

Bonjour,

Y a-t-il quelque chose en A1 ou cette colonne est purement décorative ?

A+

Le 23/04/2020 à 11:38

Bonjour,

J'ai un peu mis à la sauce mes variables...

Sub TableauMensuel()
Application.ScreenUpdating = False
Dim DerLig_Prov As Long, DerLig_Dest As Long
Dim Num_Sh As Byte

DerLig_Dest = Sheets(13).Range("B" & Rows.Count).End(xlUp).Row
If DerLig_Dest > 1 And Sheets(13).Range("B2") <> "" Then
    Sheets(13).Rows("2:" & DerLig_Dest).Delete
End If
For Num_Sh = 1 To 12
    DerLig_Prov = Sheets(Num_Sh).Range("B" & Rows.Count).End(xlUp).Row
    If DerLig_Prov > 1 Then
        Sheets(Num_Sh).Range("A2:J" & DerLig_Prov).Copy
        DerLig_Dest = Sheets(13).Range("B" & Rows.Count).End(xlUp).Row
        If Num_Sh > 1 Then DerLig_Dest = DerLig_Dest + 1
        Sheets(13).Range("A" & DerLig_Dest).PasteSpecial
        Sheets(13).Range("K" & DerLig_Dest).Resize(DerLig_Prov - 1) = Sheets(Num_Sh).Name
    End If
Next
End Sub

Un peu à la bourre..

Bonjour Galopin et Steelson

Le 23/04/2020 à 11:46

Bonjour à tous,

Steelson :

C'est good ! ça marche nikel, j'ai effectivement du ajuster la taille car cela me créer des lignes vides. Un immense merci !

Galopin01:

La ligne est totalement vide, mais le problème c'est que l'extraction qui proviens de notre logiciel nous sort des fichiers comme ça…

Cousinhub:

Merci beaucoup ! Je te deux trois petit trucs (comme le and pour éviter de coller des lignes vides)

Merci beaucoup à tous les trois,

Aussitôt ouvert, aussi clos, quelle efficacité !

Rechercher des sujets similaires à "macro qui ajoute nom onglet"