XL 2013 Séparer feuille excel en plusieurs

[yhous003]

Bonjour à tous,

j'ai besoin de votre aide pour une macro ou code vba qui me permettra de séparer automatique le contenu d'une feuille sur plusieurs autre feuille avec un nombre égale de ligne par feuille.
chaque feuille porte le nom Agent1 Agent2......

merci d'avance pour votre aide

 

[fanch55]

Bonjour,
Donnez un classeur exemple avec la feuille à diviser ...

 

[fanch55]

Bonsoir, à tester :

Sub Diviser()
Application.ScreenUpdating = False
Dim Sh As Worksheet: Set Sh = Worksheets("Feuil1")  ' Feuille à diviser
Dim Nlignes:         Nlignes = 10                   ' Nombre de lignes "identiques" à copier
Dim Ligne_Début:     Ligne_Début = 2                ' Ligne à partir de laquelle diviser
Dim Feuille As String ' Nom de la feuille à créer

    For I = Ligne_Début To Sh.UsedRange.Rows.Count Step Nlignes
        J = J + 1: Feuille = "Agent" & J
        If Not IsError(Evaluate("='" & Feuille & "'!A1")) Then
          ' Si la feuille existe, on la vide
            Worksheets(Feuille).Rows.Clear
        Else
          ' sinon on la crée
           Worksheets.Add.Name = Feuille
        End If
        ' -=-=-=-=-=-=-=-=-=-=-=-=-=-
        '     Méthode à choisir
        ' -=-=-=-=-=-=-=-=-=-=-=-=-=-
       
        ' Copie des lignes dans la nouvelle feuille
        Sh.Rows(I).Resize(Nlignes).Copy Worksheets(Feuille).Range("A1")
       
        ' Déplacement des lignes dans la nouvelle feuille
        'Sh.Rows(I).Resize(Nlignes).Cut Worksheets(Feuille).Range("A1")
    Next
    Sh.Activate
    Range("A1").Activate
End Sub

 

[job75]

Bonsoir yhous003, fanch55,

Une autre solution avec le fichier joint et cette macro dans ThisWorkbook :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim w As Worksheet, a(), n%, i As Variant, h&, titre As Range, P As Range
For Each w In Worksheets
    If LCase(w.Name) Like "agent*" Then
        ReDim Preserve a(n) 'base 0
        a(n) = w.Name
        n = n + 1
    End If
Next w
i = Application.Match(Sh.Name, a, 0)
If IsError(i) Then Exit Sub
With Sheets("Source")
    Set titre = .UsedRange.Rows(1).EntireRow
    h = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row - titre.Row
    h = Application.Ceiling(h, n) / n
    If h Then Set P = .UsedRange.Rows(2 + h * (i - 1)).Resize(h).EntireRow
End With
Application.ScreenUpdating = False
Sh.Cells.Delete 'RAZ
titre.Copy Sh.[A1]
If h Then P.Copy Sh.[A2]
Sh.Columns.AutoFit 'ajustement largeurs
End Sub

A+

 

[yhous003]

Un grand merci pour vos réponses la reponse de @job75 repond parfaitement à mon besoin

 

[fanch55]

Salut @job75 ,
Quelques petites interrogation sur le code :

• Si on démarre avec seulement la feuille Source , il ne se passe rien ...
• Le découpage se fait selon le nombre de feuilles Agent ( quelle qu'en soit la numérotation ):
  il faut donc détruire celles-ci une par une jusqu'à avoir le nombre de lignes désirées ?

 

[job75]

Bonjour fanch55

il faut donc détruire celles-ci une par une jusqu'à avoir le nombre de lignes désirées ?

Pas du tout, les lignes sont copiées (dans l'ordre) sur chaque feuille "Agent" existante.

Maintenant si l'on supprime toutes ces feuilles il y aura un bug car l'Array a n'existera pas.

On peut alors ajouter ce test après la boucle w :

If n = 0 Then Exit Sub

A+

 

[fanch55]

Pas du tout, les lignes sont copiées (dans l'ordre) sur chaque feuille "Agent" existante.

J'aurai du dire :
il faut donc détruire celles-ci une par une jusqu'à avoir le nombre de lignes désirées par feuille Agent restante?

sauf si on part du principe que la source est toujours pour le même nombre d'agents ... ?

Mais si cela suffit au demandeur ...

 

[job75]

Le nombre total de lignes est divisé par le nombre de feuilles "Agent".