Petit Soucil de division de feuille

J

JeanMikael

XLDnaute Junior
Re-re Bonjour le forum,


J'ai cette macro :


Code: 
Sub distribue4()
Dim n As Integer
Dim ftr As String
'declaration de collection
Dim criteres As Collection
Set criteres = New Collection
'creation de la collection des criteres
Application.ScreenUpdating = False

For n = 2 To Range("g65536").End(xlUp).Row
  On Error Resume Next
    criteres.Add Range("g" & n), CStr(Range("g" & n))
  On Error GoTo 0
Next n

'ajout d'une feuille par critere
For n = 1 To criteres.Count

  Sheets.Add.Name = "Erreur " & criteres(n)

  Sheets("Feuil1").Range("A1:AD1").Copy Destination:=ActiveSheet.Range("A1")

Next n

'tansfert vers les feuilles
For n = 2 To Sheets("Feuil1").Range("g65536").End(xlUp).Row

  ftr = "Erreur " & Sheets("Feuil1").Range("g" & n)
 
  Sheets("Feuil1").Range("A" & n & ":AD" & n).Copy Destination:=Sheets(ftr).Range("A65536").End(xlUp).Offset(1, 0)

Sheets("Feuil1").Select

Next n

Application.ScreenUpdating = True

End Sub

Cette macro me permet de créer un onglet pour chaque valeur rencontrer dans la colonne G, dans cette colonne ce sont des chiffre jusque là tout va bien, mon soucil c'est que dans ma colonne j'ai par exemple des chiffre de 0 à 9 donc mon code va crée un onglet nommé Erreur 1 par exemple et ce que je souhaiterai c'est ajouter un 0 pour les onglet qui vont de Erreur 1 à 9 donc j'aurai par exemple comme nom d'onglet Erreur 01, j'ai essayé de mettre dans ma colonne G un format personnalisée qui met un 0 devant les chiffres allant de 1 à 9 met la macro lorsqu'elle divise les onglets ne tient pas compte du format personalisée, comment faire pour obtenir le résultat souhaité ?
d'avance merci de votre aide, bonne après-midi.

Cordialement,
Jean-Mikaël
 
Trier par date Trier par votes
J

JeanMikael

XLDnaute Junior
Re : Division d'Onglet

Re-re Bonjour le forum,


J'ai cette macro :



Code: 
Sub distribue4()
Dim n As Integer
Dim ftr As String
'declaration de collection
Dim criteres As Collection
Set criteres = New Collection
'creation de la collection des criteres
Application.ScreenUpdating = False

For n = 2 To Range("g65536").End(xlUp).Row
  On Error Resume Next
    criteres.Add Range("g" & n), CStr(Range("g" & n))
  On Error GoTo 0
Next n

'ajout d'une feuille par critere
For n = 1 To criteres.Count

  Sheets.Add.Name = "Erreur " & criteres(n)

  Sheets("Feuil1").Range("A1:AD1").Copy Destination:=ActiveSheet.Range("A1")

Next n

'tansfert vers les feuilles
For n = 2 To Sheets("Feuil1").Range("g65536").End(xlUp).Row

  ftr = "Erreur " & Sheets("Feuil1").Range("g" & n)
 
  Sheets("Feuil1").Range("A" & n & ":AD" & n).Copy Destination:=Sheets(ftr).Range("A65536").End(xlUp).Offset(1, 0)

Sheets("Feuil1").Select

Next n

Application.ScreenUpdating = True

End Sub

Cette macro me permet de créer un onglet pour chaque valeur rencontrer dans la colonne G, dans cette colonne ce sont des chiffre jusque là tout va bien, mon soucil c'est que dans ma colonne j'ai par exemple des chiffre de 0 à 9 donc mon code va crée un onglet nommé Erreur 1 par exemple et ce que je souhaiterai c'est ajouter un 0 pour les onglet qui vont de Erreur 1 à 9 donc j'aurai par exemple comme nom d'onglet Erreur 01, j'ai essayé de mettre dans ma colonne G un format personnalisée qui met un 0 devant les chiffres allant de 1 à 9 met la macro lorsqu'elle divise les onglets ne tient pas compte du format personalisée, comment faire pour obtenir le résultat souhaité ?
d'avance merci de votre aide, bonne après-midi.

Cordialement,
Jean-Mikaël
 
Vote positif 0 Vote négatif
Gorfael

Gorfael

XLDnaute Barbatruc
Re : Petit Soucil de division de feuille

JeanMikael à dit:
Re-re Bonjour le forum,


J'ai cette macro :


Code: 
Sub distribue4()
Dim n As Integer
Dim ftr As String
'declaration de collection
Dim criteres As Collection
Set criteres = New Collection
'creation de la collection des criteres
Application.ScreenUpdating = False
 
For n = 2 To Range("g65536").End(xlUp).Row
  On Error Resume Next
    criteres.Add Range("g" & n), CStr(Range("g" & n))
  On Error GoTo 0
Next n
 
'ajout d'une feuille par critere
For n = 1 To criteres.Count
 
  Sheets.Add.Name = "Erreur " & criteres(n)
 
  Sheets("Feuil1").Range("A1:AD1").Copy Destination:=ActiveSheet.Range("A1")
 
Next n
 
'tansfert vers les feuilles
For n = 2 To Sheets("Feuil1").Range("g65536").End(xlUp).Row
 
  ftr = "Erreur " & Sheets("Feuil1").Range("g" & n)
 
  Sheets("Feuil1").Range("A" & n & ":AD" & n).Copy Destination:=Sheets(ftr).Range("A65536").End(xlUp).Offset(1, 0)
 
Sheets("Feuil1").Select
 
Next n
 
Application.ScreenUpdating = True
 
End Sub

Cette macro me permet de créer un onglet pour chaque valeur rencontrer dans la colonne G, dans cette colonne ce sont des chiffre jusque là tout va bien, mon soucil c'est que dans ma colonne j'ai par exemple des chiffre de 0 à 9 donc mon code va crée un onglet nommé Erreur 1 par exemple et ce que je souhaiterai c'est ajouter un 0 pour les onglet qui vont de Erreur 1 à 9 donc j'aurai par exemple comme nom d'onglet Erreur 01, j'ai essayé de mettre dans ma colonne G un format personnalisée qui met un 0 devant les chiffres allant de 1 à 9 met la macro lorsqu'elle divise les onglets ne tient pas compte du format personalisée, comment faire pour obtenir le résultat souhaité ?
d'avance merci de votre aide, bonne après-midi.

Cordialement,
Jean-Mikaël
Cliquez pour agrandir...
Salut
comme j'ai la flemme, j'ai pas tout regarder, juste la description du problème
remplacer :
ftr = "Erreur " & Sheets("Feuil1").Range("g" & n)
par
ftr = "Erreur " & format(Sheets("Feuil1").Range("g" & n);"00")
Juste une question au hazard : si t'as un problème d'erreur Excel en plein milieux de ta macro, comment tu exécute ScreenUpDating = True ?
Mais il n'y a aucun risque d'erreur,... normalement
A+
 
Vote positif 0 Vote négatif
Cousinhub

Cousinhub

XLDnaute Barbatruc
Re : Petit Soucil de division de feuille

Re-, JeanMikael, bonjour Gorfael

une autre solution :

Sheets.Add.Name = IIf(Len(criteres(n)) = 1, "Erreur 0" & criteres(n), "Erreur " & criteres(n))

Gorfael,
Il me semble que le ScreenUpdating est remis automatiquement à True lorsqu'on stoppe la macro (par End Sub ou arrêt suite à Bug), mais peut-être me trompais-je?
 
Vote positif 0 Vote négatif
J

JeanMikael

XLDnaute Junior
Re : Petit Soucil de division de feuille

Re, bhbh

La ligne que tu m'a filé à l'air de marcher le seul truc c'est que le programme
s'arrete à cette ligne :

Code: 
Sheets("Feuil1").Range("A" & n & ":AD" & n).Copy Destination:=Sheets(ftr).Range("A65536").End(xlUp).Offset(1, 0)

Cordialement,
Jean-Mikaël
 
Vote positif 0 Vote négatif
J

JeanMikael

XLDnaute Junior
Re : Petit Soucil de division de feuille

Ci-joint le fichier exemple avec la macro d'origine sans les ajout de vos différentes suggestions, merci de ton aide.



Cordialement,
Jean-Mikaël
 

Pièces jointes

  • jeanmikael.xls
    30.5 KB · Affichages: 30
  • jeanmikael.xls
    30.5 KB · Affichages: 39
  • jeanmikael.xls
    30.5 KB · Affichages: 28
Vote positif 0 Vote négatif
Cousinhub

Cousinhub

XLDnaute Barbatruc
Re : Petit Soucil de division de feuille

Ok, pas besoin de fichier,

remplace par :

ftr = "Erreur " & Sheets("Feuil1").Range("g" & n)
ftr = IIf(Len(ftr) < 9, "Erreur 0" & Sheets("Feuil1").Range("g" & n), "Erreur " & Sheets("Feuil1").Range("g" & n))
 
Vote positif 0 Vote négatif
Cousinhub

Cousinhub

XLDnaute Barbatruc
Re : Petit Soucil de division de feuille

Re-,
effectivement, difficile de dépanner si tu n'appliques pas les conseils qu'on te donne...;), et que nous, on essaie avec ce qu'on t'a préconisé...

ton code modifié :

Dim criteres As Collection
Set criteres = New Collection
'creation de la collection des criteres
Application.ScreenUpdating = False
For n = 3 To Range("g65536").End(xlUp).Row
On Error Resume Next
criteres.Add Range("g" & n), CStr(Range("g" & n))
On Error GoTo 0
Next n
'ajout d'une feuille par critere
For n = 1 To criteres.Count
Sheets.Add.Name = IIf(Len(criteres(n)) = 1, "Erreur 0" & criteres(n), "Erreur " & criteres(n))
Sheets("liste").Range("A1:AD1").Copy Destination:=ActiveSheet.Range("A1")
Next n
'tansfert vers les feuilles
For n = 3 To Sheets("liste").Range("g65536").End(xlUp).Row
ftr = "Erreur " & Sheets("liste").Range("g" & n)
ftr = IIf(Len(ftr) < 9, "Erreur 0" & Sheets("liste").Range("g" & n), "Erreur " & Sheets("liste").Range("g" & n))
Sheets("liste").Range("A" & n & ":AD" & n).Copy Destination:=Sheets(ftr).Range("A65536").End(xlUp).Offset(1, 0)
Next n
Application.ScreenUpdating = True
End Sub

Celui là fonctionne, je l'ai testé...
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Résolu(e)
Microsoft 365 Recherche à partir d'une TextBox
Réponses
4
Affichages
201
Francky79
F
halecs93
  • Résolu(e)
XL 2016 Indice n'appartient pas à la sélection : HELP !!!!
2
Réponses
21
Affichages
648
halecs93
halecs93
T
  • Question
XL 2016 Optimisation d'une boucle
2 3
Réponses
30
Affichages
1 K
thivame
T
Regueiro
  • Question
Microsoft 365 Format Nombre Combobox dans Feuille
Réponses
3
Affichages
210
fanch55
fanch55
M
  • Question
Microsoft 365 Copier / coller avec mise en forme VBA
Réponses
0
Affichages
200
marie3107
M
Sergent_Lipton
  • Résolu(e)
Microsoft 365 [VBA] Barre de recherche dynamique - objectif : cacher les lignes hors résultat
Réponses
3
Affichages
224
Sergent_Lipton
Sergent_Lipton
B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
280
Compte Supprimé 979
C
A
  • Résolu(e)
XL 2019 Passage de 2013 pro à 2019 pro, Pb avec formule VBA, liens hypertexte
2 3 4
Réponses
54
Affichages
2 K
sylvanu
sylvanu
Z
  • Question
XL 2021 VBA Prélèvement d'une donnée si une valeur recherchée est identique
Réponses
3
Affichages
222
ZiM
Z
A
  • Résolu(e)
XL 2010 Renomer copie de feuilles multiple
Réponses
5
Affichages
230
sylvanu
sylvanu

Membres actuellement en ligne

17 membres et 117 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 499
Messages
2 089 002
Membres
104 002
dernier inscrit
SkrauzTTV