Diviser une feuille en plusieurs feuilles

[Florian699]

Bonjour,

mon problème du jour est le suivant :

j'ai une feuille excel avec 2 colonnes (A et B) et des données dans chacune d'elle. Le nombre de ligne est de un peu de 10000 dans mon fichier final.
Dans la colonne A il y a des n° avec un titre (ex: 37. les chaussures).

Ce que je souhaite faire (mais je n'y arrive pas), c'est de créer automatiquement une nouvelle feuille pour chaque titre de la colonne A (avec le titre sur la nouvelle feuille) est de mettre toutes les données de ce titre (des 2 colonnes A et B) dans cette nouvelle feuille. Et ceci pour tous les titres qu'il rencontrera dans la colonne A. Ceci devrait donnait 256 nouvelles feuilles avec leurs données respectives.

Voilà, voilà

Si quelqu'un pouvait m'aider je le remercie d'avance

Ps je mets une partie de mon fichier en pj

 

[pierrejean]

Bonjour Florian

Un essai

 

[Florian699]

Super cela marche nickel chrome

Merci beaucoup pierrejean !

 

[Florian699]

Juste une petite modification à effectuer :
quand les feuilles se créent, elles le font sur la gauche de la feuille de départ et celle-ci se retrouve en fait à la fin de toutes les feuilles. Et c'est un peu génant.
Il faudrait que la création des feuilles se fassent à la droite de la feuille de départ avec une incrémentation dans l'ordre croissant des feuilles.

Voilà si c'était possible cela m'aiderait bien ...

 

[job75]

Bonsoir Florian, Pierre,

pierrejean doit être allé se coucher. Remplacez :

Sheets.Add.Name = nom

par :

Sheets.Add(After:=Sheets(Sheets.Count)).Name = nom

Bonne nuit.

 

[job75]

Bonjour Florian, Pierre, le forum,

Une solution voisine dans le fichier joint :

Sub CreerFeuilles()
Dim n%, t, i&, j&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
'---ne garde que la 1ère feuille---
For n = Sheets.Count To 2 Step -1
  Sheets(n).Delete
Next
'---crée les feuilles---
t = Sheets(1).UsedRange.Resize(, 2) 'au moins 2 éléments
For i = 1 To UBound(t)
  If t(i, 1) Like Val(t(i, 1)) & ".*" Then
    Sheets.Add(After:=Sheets(n)).Name = Val(t(i, 1))
    If n > 1 Then Sheets(1).Rows(j & ":" & i - 1).Copy Sheets(n).[A1]: Sheets(n).Columns.AutoFit
    j = i
    n = n + 1
  End If
Next
Sheets(1).Rows(j & ":" & i).Copy [A1]: Columns.AutoFit
Sheets(1).Select
End Sub

La suppression des feuilles au début permet de les mettre à jour si nécessaire.

Bonne journée.

 

[job75]

Re,

S'il y a plusieurs feuilles à ne pas supprimer :

Sub CreerFeuilles()
Dim a, S As Worksheet, n%, der%, t, i&, j&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
a = Array("Base", "Feuil2", "Feuil3") 'nom des feuilles à ne pas supprimer, à adapter
Set S = Sheets(a(0)) 'feuille source, à adapter
'---supprime les feuilles---
For n = Sheets.Count To 1 Step -1
  If IsError(Application.Match(Sheets(n).Name, a, 0)) Then Sheets(n).Delete
Next
n = Sheets.Count: der = n
'---crée les feuilles---
t = S.UsedRange.Resize(, 2) 'au moins 2 éléments
For i = 1 To UBound(t)
  If t(i, 1) Like Val(t(i, 1)) & ".*" Then
    Sheets.Add(After:=Sheets(n)).Name = Val(t(i, 1))
    If n > der Then S.Rows(j & ":" & i - 1).Copy Sheets(n).[A1]: Sheets(n).Columns.AutoFit
    j = i
    n = n + 1
  End If
Next
S.Rows(j & ":" & i).Copy [A1]: Columns.AutoFit
S.Select
End Sub

Fichier (2).

A+

 

[Florian699]

Bonjour,

super j'ai essayé les différentes possibilités et cela marche très bien !!
Merci à vous et bon dimanche

A+

 

[Florian699]

dernière question :
comment puis-je avec le code de Pierre faire en sorte que le nom des feuilles créées = nom de la partie créée ?
exemple : aujourd'hui j'ai comme nome de feuille créée 1., 2., 3. etc ... et je voudrais avoir 1.Les pronoms 2. Greetings. Salutations. Farewells etc ...

Merci d'avance

et voici le code pour rappel

Sub test()
tablo = Sheets("Feuil1").Range("A1:B" & Sheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Row)
debut = 1
nom = "1."
For n = LBound(tablo, 1) + 1 To UBound(tablo, 1)
If (IsNumeric(Left(tablo(n, 1), 1)) And InStr(tablo(n, 1), ".") <> 0) Or n = UBound(tablo, 1) Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = nom
Sheets("Feuil1").Range(Cells(debut, 1).Address & ":" & Cells(n - 1, 2).Address).Copy Destination:=ActiveSheet.Range("A1")
debut = n
nom = Split(tablo(n, 1))(0)
End If
Next
End Sub

 

[job75]

Bonjour,

Sub CreerFeuilles()
Dim a, S As Worksheet, n%, der%, t, i&, gauche%, j&
a = Array("Base", "Feuil2", "Feuil3") 'noms des feuilles à ne pas supprimer, à adapter
Set S = Sheets(a(0)) 'feuille source, à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
'---supprime les feuilles---
For n = Sheets.Count To 1 Step -1
  If IsError(Application.Match(Sheets(n).Name, a, 0)) Then Sheets(n).Delete
Next
n = Sheets.Count: der = n
'---crée les feuilles---
t = S.UsedRange.Resize(, 2) 'au moins 2 éléments
For i = 1 To UBound(t)
  If t(i, 1) Like Val(t(i, 1)) & ".*" Then
    With Sheets.Add(After:=Sheets(n))
      For gauche = 31 To 1 Step -1 'le nom d'une feuille ne doit pas avoir plus de 31 caractères
        .Name = Left(t(i, 1), gauche)
        If .Name = Left(t(i, 1), gauche) Then Exit For 's'il n'y a pas de caractères interdits
      Next
    End With
    If n > der Then S.Rows(j & ":" & i - 1).Copy Sheets(n).[A1]: Sheets(n).Columns.AutoFit
    j = i
    n = n + 1
  End If
Next
S.Rows(j & ":" & i).Copy [A1]: Columns.AutoFit
S.Select
End Sub

Il faut savoir qu'un nom de feuille ne doit pas avoir plus de 31 caractères et qu'il y a des caractères interdits.

Je découvre ici, avec la 3ème feuille créée, qu'en plus le dernier caractère ne doit pas être une apostrophe '.

Fichier (3).

A+

 

[Florian699]

Merci de ta réponse dominicale, cela marche très bien