Copier plusieurs colonnes d'une feuille dans plusieurs feulles

[Diane_courie]

Bonjour,

J'ai une feuille "Base retravaillée" je dois copier les colonnes A B C D dans une autre feuille puis, A B C E dans une autre puis, A B C F dans une autre et ainsi de suite. Et ce très régulièrement.
Je n'arrive pas a réaliser une macro allant dans ce sens.

Merci d'avance
Diane

 

[vgendron]

Bonjour et bienvenu ici

Si je suis ta logique 'copier ABC-D puis ABC-E puis ABC-F... dans ton fichier tu vas te retouver avec 115 feuilles...??

 

[job75]

Bonjour Diane_courie, vgendron,

dans ton fichier tu vas te retouver avec 115 feuilles...??

Ben oui sinon rien de drôle :

Private Sub CommandButton1_Click()
Dim i%, a$, j%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'---RAZ---
Me.Move Before:=Sheets(1)
For i = Sheets.Count To 2 Step -1
    Sheets(i).Delete
Next
'---création des feuilles---
With Range("A1", UsedRange).EntireColumn
    For i = 4 To .Columns.Count
        a = Split(.Columns(i).Address(0, 0), ":")(0)
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = "ABC-" & a
        j = .Cells(2, i).MergeArea.Columns.Count 'pour DM2:DN2 qui sont fusionnées
        Union(.Columns(1).Resize(, 3), .Columns(i).Resize(, j)).Copy ActiveSheet.Range("A1")
        i = i + j - 1
    Next
End With
Me.Activate
End Sub

Les cellules fusionnées doivent se trouver uniquement en ligne 2 (voir DM2: DN2).

Fichier joint.

A+

 

[Lone-wolf]

Bonjour à tous

@job75

Ben oui sinon rien de drôle + Les cellules fusionnées doivent se trouver uniquement en ligne 2 (voir DM2N2).

Et ça te fais marrer

 

[vgendron]

Hello @job75 , @Lone-wolf

Je posais la question. parce que quand on regarde les colonnes ... certaines sont nommées "Total".......
je pressens une demande légèrement différente... :-D

 

[merinos]

Tu veyx vraiment "copier"

ou tu veux analyser tes données... et comme elles sont deja "pivotées" tu veux les "dé-pivoter"?

La fonction "unpivot" existe...

 

[Diane_courie]

Bonjour et bienvenu ici

Si je suis ta logique 'copier ABC-D puis ABC-E puis ABC-F... dans ton fichier tu vas te retouver avec 115 feuilles...??

Oui c'est exactement cela

 

[merinos]

et voila une solution sans VBA...

 

[job75]

Re, salut Lone-wolf, merinos,

Est-il possible de renommer les feuilles générés avec la ligne 2 et 3 de chaque colonne.

Sans trop bousculer ses neurones :

Private Sub CommandButton1_Click()
Dim i%, j%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next 'si un nom de feuille est déjà utilisé
'---RAZ---
Me.Move Before:=Sheets(1)
For i = Sheets.Count To 2 Step -1
    Sheets(i).Delete
Next
'---création des feuilles---
With Range("A1", UsedRange).EntireColumn
    For i = 4 To .Columns.Count
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = .Cells(2, i) & " " & .Cells(3, i)
        j = .Cells(2, i).MergeArea.Columns.Count 'pour DM2:DN2 qui sont fusionnées
        Union(.Columns(1).Resize(, 3), .Columns(i).Resize(, j)).Copy ActiveSheet.Range("A1")
        ActiveSheet.Columns(4).Resize(, j).AutoFit 'ajustement largeur
        i = i + j - 1
    Next
End With
Me.Activate
End Sub

Fichier (2).

Edit : fichier (2 bis) avec ajout des variables x et dL pour que toutes les feuilles soient nommées.

A+

 

[job75]

Re,

Vous êtes gourmande Diane, mais c'est faisable, je verrai cela dans la soirée.

Pas besoin de réduire les libellés en ligne 2, la macro peut les adapter (maxi 31 caractères pour un nom d'onglet).

A+

 

[job75]

Re,

Légère retouche au fichier (2) pour les largeurs des colonnes.

Avec ce fichier (3) création des 11 fichiers demandés :

Private Sub CommandButton1_Click()
Dim chemin$, d As Object, i%, x$, nomfich$, dL%, wb As Workbook, F As Worksheet, j%
chemin = ThisWorkbook.Path & "\Mes fichiers\" 'nom du dossier à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
'---création des classeurs---
MkDir chemin 'création du sous-dossier
Set d = CreateObject("Scripting.Dictionary")
With Range("A1", UsedRange).EntireColumn
    For i = 4 To .Columns.Count
        x = .Cells(2, i)
        nomfich = Split(x)(0) & ".xls"
        dL = Len(x) + Len(.Cells(3, i)) - 30 'nom d'onglet limité à 31 caractères
        If Not d.exists(nomfich) Then
            d(nomfich) = ""
            Workbooks(nomfich).Close
            Workbooks.Add(xlWBATWorksheet).SaveAs chemin & nomfich, 56 'fichier .xls
        End If
        Set wb = Workbooks(nomfich)
        Set F = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)) 'nouvelle feuille
        F.Name = Left(x, Len(x) - dL) & " " & .Cells(3, i)
        j = .Cells(2, i).MergeArea.Columns.Count 'pour DM2:DN2 qui sont fusionnées
        Union(.Columns(1).Resize(, 3), .Columns(i).Resize(, j)).Copy F.Range("A1")
        F.Columns(4).Resize(, j).AutoFit 'ajustement largeur
        i = i + j - 1
    Next i
End With
'---fermeture des classeurs---
For Each wb In Workbooks
    If d.exists(wb.Name) Then
        wb.Activate
        wb.Sheets(1).Delete
        wb.Sheets(1).Activate
        wb.Close True 'avec enregistrement
    End If
Next wb
End Sub

A+

 

[job75]

Re,

Chez moi la dernière macro s'exécute en 18 secondes

C'est un peu long mais pas moyen d'aller plus vite.

Bonne nuit

 

[Diane_courie]

Bonjour,

C'est super, merci beaucoup vous m'avez évité de nombreuses heures de copier-coller.

Diane

 

[job75]

Bonjour Diane, le forum,

Au post #11 j'ai ajouté le fichier (2 bis) pour que toutes les feuilles soient nommées.

Bonne journée.

 

[Diane_courie]

Merci beaucoup.
Je vais me replonger dans la création de macro... j'avais tout oublié. Pas facile pour s'y remettre
Diane