Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2019 Interrompre une boucle quand la condition n'est plus remplie

D

DJISA

XLDnaute Occasionnel
Bonjour le forum!
Avec le code ci-dessous, nous avons créer une boucle pour la création d'un nombre d'onglets prédéfini, ici huit(8), voir la ligne en gras. Mais Nous voudrions aller plus loin en créant une boucle, avec une variable onglet , qui s'interromperait au dernier élément de la liste dont l'étendue dépend de l'utilisateur.
Nous joignons une fichier

VB: 
Sub mes_classes()
[B]For Each cell In Range("A5:A12")[/B]
Set feuille = Worksheets.Add(After:=Worksheets(Worksheets.Count))

feuille.Name = cell.Value
feuille.Range("C4").Value = "Classe"
feuille.Range("D4").Value = "Nro"
feuille.Range("E4").Value = "Prénom"
feuille.Range("F4").Value = "Nom"
feuille.Range("G4").Value = "Date de naissance"
feuille.Range("H4").Value = "Lieu de naissance"
feuille.Range("I4").Value = "Sexe"
feuille.Range("J4").Value = "Age"
feuille.Range("K4").Value = "Tutelle"
feuille.Range("L4").Value = "Adresse tutelle"
feuille.Range("M4").Value = "Tél tutelle"
feuille.Range("N4").Value = "Tél élève"
feuille.Range("O4").Value = "Orphelin"
feuille.Range("P4").Value = "Handicap"
feuille.Range("Q4").Value = "Dossier"
feuille.Range("R4").Value = "Nro ext"

feuille.Range("C5").Value = cell.Offset(0, 1).Value
feuille.Range("D5").Value = cell.Offset(0, 1).Value
feuille.Range("E5").Value = cell.Offset(0, 1).Value
feuille.Range("F5").Value = cell.Offset(0, 1).Value
feuille.Range("G5").Value = cell.Offset(0, 1).Value
feuille.Range("H5").Value = cell.Offset(0, 1).Value
feuille.Range("I5").Value = cell.Offset(0, 1).Value
feuille.Range("J5").Value = cell.Offset(0, 1).Value
feuille.Range("K5").Value = cell.Offset(0, 1).Value
feuille.Range("L5").Value = cell.Offset(0, 1).Value
feuille.Range("M5").Value = cell.Offset(0, 1).Value
feuille.Range("N5").Value = cell.Offset(0, 1).Value
feuille.Range("O5").Value = cell.Offset(0, 1).Value
feuille.Range("P5").Value = cell.Offset(0, 1).Value
feuille.Range("Q5").Value = cell.Offset(0, 1).Value
feuille.Range("R5").Value = cell.Offset(0, 1).Value
Next cell

End Sub

Merci d'avance
DJISA
 

Pièces jointes

  • Po.xlsm
    28.9 KB · Affichages: 10
Trier par date Trier par votes

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Djisa, Claudy,
J'ai du mal à croire que votre code fonctionnait, tout du moins sous XL2007.
VB: 
Votre code :
feuille.Range("C4").Value = "Classe"
Code qui marche :
Sheets(feuille).Range("C4").Value = "Classe"

Votre code :
Set feuille = Worksheets.Add(After:=Worksheets(Worksheets.Count))
Code qui marche :
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = Nom
feuille = cell.Value
En PJ, les feuilles crées sont celles dans la liste Créer des classes. Il s'arrete à la fin de la lite.
A noter qu'il n'y a aucune sécurité dans votre code. Si on appuie une seconde fois, cela génère une erreur car les feuilles existent déjà.
 

Pièces jointes

  • Po.xlsm
    25.6 KB · Affichages: 1
Vote positif 0 Vote négatif

patricktoulon

XLDnaute Barbatruc
bonjour
@sylvanu allons!!! c'est un tableau structuré

tu a un tableau structuré tu n'a donc plus a te soucier de connaitre la fin ,le databodyrange de tableau1 te donne la plage sans l’entête
VB: 
Sub mes_classes()
    Dim index&, cell As Range, Feuille As Worksheet
    For Each cell In Feuil1.ListObjects("Tableau1").DataBodyRange
        index = index + 1
        If TypeName(Evaluate(cell.Text & "!A:B")) <> "Range" Then
            With Worksheets.Add(after:=Worksheets(index))
                .Name = cell.Value
                .Range("C4:r4").Value = Feuil1.[C4:R4].Value
                .Range("C5:r5").Value = Feuil1.[C5:R5].Value
            End With
        End If
    Next cell
End Sub
et la sécurité en ce qui concerne l’existence d'un onglet est gérer
tu peux lancer et relancer autant de fois que tu veux ça n'ajoutera que les onglets manquants et en prime si je me suis pas trompé dans le même ordre
 
Vote positif 0 Vote négatif
D

DJISA

XLDnaute Occasionnel
Salut Patricktoulon, le forum!
J'ai testé ton code et cela marche. Merci beaucoup!
Mais est-il possible d'intégrer dans la boucle une mise en forme qui s'appliquera à toutes les feuilles qui seront crées. Je voudrais que les pages se créent avec des tableaux identiques à celui figurant dans la feuil1.
Je te renvoie le fichier avec une petite modification à la feuil1.
Merci.
 

Pièces jointes

  • Po.xlsm
    30 KB · Affichages: 7
Vote positif 0 Vote négatif

patricktoulon

XLDnaute Barbatruc
RE
bonjour
VB: 
Sub mes_classes()
    Dim index&, cell As Range, Feuille As Worksheet
    For Each cell In Feuil1.ListObjects("Tableau1").DataBodyRange
        index = index + 1
        If TypeName(Evaluate(cell.Text & "!A:B")) <> "Range" Then
            With Worksheets.Add(after:=Worksheets(index))
                .Name = cell.Value
                .Range("C4:R5").Value = Feuil1.[C4:R5].Value
                .ListObjects.Add(xlSrcRange, Range("C4:R5"), , xlYes).Name = "Tableau_" & cell.Value
                .ListObjects("Tableau_" & cell.Value).TableStyle = "TableStyleMedium2"
            End With
        End If
    Next cell
End Sub
 
Vote positif 0 Vote négatif
D

DJISA

XLDnaute Occasionnel
Salut Patricktoulon, le Forum!
J'ai testé le code mais cela marche en partie. J'ai constaté que, dans les nouveaux onglets créés, les tableaux ne respectent pas les mêmes largeurs de colonne et la police d'écriture définies dans le tableau figurant dans l'onglet "maquette".
Merci
DJISA
 
Vote positif 0 Vote négatif

patricktoulon

XLDnaute Barbatruc
re
vite fait comme ça on passe plus par value mais par (copy / destination)(sans paste!!)
on arrange les colonne après
VB: 
Sub mes_classes()
    Dim index&, cell As Range, Feuille As Worksheet,col as range
    For Each cell In Feuil1.ListObjects("Tableau1").DataBodyRange
        index = index + 1
        If TypeName(Evaluate(cell.Text & "!A:B")) <> "Range" Then
            With Worksheets.Add(after:=Worksheets(index))
                .Name = cell.Value
                Feuil1.[C4:R5].Copy Destination:=.Range("C4")
                .ListObjects(1).Name = "tableau_" & .Name
                For Each col In .Range("C4:R5").Columns
                    col.ColumnWidth = Feuil1.Columns(col.Column).ColumnWidth
                Next
            End With
        End If
    Next cell
End Sub

oui je sais cette ligne est amusante
col.ColumnWidth = Feuil1.Columns(col.Column).ColumnWidth
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…