Diviser une feuille en plusieurs feuilles

Florian699

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

Pièces jointes

  • fichier test forum.xls
    85.5 KB · Affichages: 86

Florian699

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

XLDnaute Barbatruc
Bonjour Florian, Pierre, le forum,

Une solution voisine dans le fichier joint :
Code:
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.
 

Pièces jointes

  • fichier test forum(1).xls
    109 KB · Affichages: 69
Dernière édition:

job75

XLDnaute Barbatruc
Re,

S'il y a plusieurs feuilles à ne pas supprimer :
Code:
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+
 

Pièces jointes

  • fichier test forum(2).xls
    110 KB · Affichages: 72
Dernière édition:

Florian699

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

XLDnaute Barbatruc
Bonjour,
Code:
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+
 

Pièces jointes

  • fichier test forum(3).xls
    146 KB · Affichages: 83
Dernière édition:

Discussions similaires

Membres actuellement en ligne

Aucun membre en ligne actuellement.

Statistiques des forums

Discussions
312 871
Messages
2 093 102
Membres
105 627
dernier inscrit
jean-marc.brillant