Copier plusieurs colonnes d'une feuille dans plusieurs feulles

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Diane_courie

XLDnaute Nouveau
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
 

Pièces jointes

Bonjour Diane_courie, vgendron,
dans ton fichier tu vas te retouver avec 115 feuilles...??
Ben oui sinon rien de drôle :
Code:
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+
 

Pièces jointes

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 :
Code:
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+
 

Pièces jointes

Dernière édition:
Re,

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

Avec ce fichier (3) création des 11 fichiers demandés :
Code:
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+
 

Pièces jointes

Dernière édition:
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
9
Affichages
367
Retour