Eclater un tableau en x onglets de x lignes

Bonjour le forum

je trouve partout un code qui permet de séparer un classeur excel en autant de fichiers que de feuilles

Moi je suis à la recherche d'un code qui éclate un listing contenu dans une feuille en x onglets de 50 lignes par exemples dans le même fichier

Si vous connaissez ou avez ça

Merci pour votre aide et pour votre attention

Bonjour

Tu devrais fournir un fichier exemple en indiquant ce que tu as au départ et ce que tu veux obtenir...

Bye !

En attendant ton fichier, ... voici un outil générique.

Les données sont contenues dans un premier onglet.

Tu donnes la lettre de la colonne qui sert de critère d'éclatement ... et tu t'éclates.

Bonsoir le forum

Bonsoir gmb et steelson merci pour votre attention et pour le fichier

je joins le fichier, je ne l'avais pas encore

les explications se trouvent sur la feuille "Data", les autre sont un début de ce que je cherche à faire

merci pour votre aide

Bonsoir,

A tester...

Option Explicit

Sub CopyToNewWorksheets()
Dim wb As Workbook
Dim ws As Worksheet, wsData As Worksheet, wsNew As Worksheet
Dim lastCol As Long, lastRow As Long
Dim rng As Range, rng2 As Range
Dim Counter As Long, I As Long

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    Set wsData = wb.Worksheets("ABC")

    For Each ws In wb.Worksheets
        If ws.Name <> wsData.Name Then ws.Delete
    Next ws

    Application.DisplayAlerts = True

    With wsData
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set rng = .Range(.Cells(1), .Cells(lastCol))
        For I = 2 To lastRow Step 50
            Set rng2 = .Cells(I, 1).Resize(50, lastCol)
            Set wsNew = wb.Worksheets.Add(after:=Worksheets(Worksheets.Count))
            Counter = wb.Worksheets.Count
            wsNew.Name = wsData.Name & "_" & Counter
            rng.Copy Destination:=wsNew.Cells(1)
            rng2.Copy Destination:=wsNew.Cells(2, 1)
            wsNew.Range("A1,H1,J1").EntireColumn.Hidden = True
            Application.CutCopyMode = False
        Next I
    End With

    wsData.Activate

    Set rng2 = Nothing: Set rng = Nothing
    Set wsNew = Nothing: Set wsData = Nothing
    Set wb = Nothing

End Sub

Bonjour le forum

Bonjour Jean-Eric merci de ton attention et pour ton aide

Le code fonctionne, mais il ne me reporte pas la largeur des colonnes est-il possible d'intégrer cette fonction,

et puis mais la se serait un plus est-il possible de numéroter les feuilles en partant de 1 vers ..... lors de leur création ?

Autrement c'est super merci

Bonjour,

Voir procédure modifiée en conséquence.

Cdlt.

Option Explicit

Sub CopyToNewWorksheets()
Dim wb As Workbook
Dim ws As Worksheet, wsData As Worksheet, wsNew As Worksheet
Dim lastCol As Long, lastRow As Long, lRow As Long
Dim rng As Range, rng2 As Range
Dim Counter As Long, I As Long
Dim modeCalc As XlCalculation

    With Application
        modeCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    Set wb = ActiveWorkbook
    Set wsData = wb.Worksheets(1)
    lRow = 50

    For Each ws In wb.Worksheets
        If ws.Name <> wsData.Name Then ws.Delete
    Next ws
    Application.DisplayAlerts = True

    With wsData
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set rng = .Range(.Cells(1), .Cells(lastCol))
        For I = 2 To lastRow Step lRow
            Set rng2 = .Cells(I, 1).Resize(lRow, lastCol)
            Set wsNew = wb.Worksheets.Add(after:=Worksheets(Worksheets.Count))
            Counter = wb.Worksheets.Count - 1
            With wsNew
                .Name = wsData.Name & "_" & Counter
                rng.Copy Destination:=.Cells(1)
                rng2.Copy Destination:=.Cells(2, 1)
                .Range(.Cells(1), .Cells(lastCol)).EntireColumn.AutoFit
                .Range("A1,H1,J1").EntireColumn.Hidden = True
            End With
            Application.CutCopyMode = False
        Next I
    End With

    wsData.Activate
    Application.Calculation = modeCalc

    Set rng2 = Nothing: Set rng = Nothing
    Set wsNew = Nothing: Set wsData = Nothing
    Set wb = Nothing

End Sub

Bravo Jean-Eric

Steelson a écrit :

En attendant ton fichier, ... voici un outil générique.

Les données sont contenues dans un premier onglet.

Tu donnes la lettre de la colonne qui sert de critère d'éclatement ... et tu t'éclates.

... et qui pouvait aussi très bien fonctionner !

Ok Jean-Eric super merci beaucoup

Merci Steelson, je prends aussi ça pourrai me servir