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

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
 
Ce fil a été résolu! Aller à la solution…

Fichiers joints

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à.
 

Fichiers joints

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
 

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.
 

Fichiers joints

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
;)
 

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
 

patricktoulon

XLDnaute Barbatruc
re
bonsoir heuuu... c'est moi ou il y a eu une soudaine disparition de moquette chez toi ? ;)
je n'est pas vu d'onglet maquette dans ton fichier ;):cool:
 
Ce message a été identifié comme étant une solution!

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
;)
 

DJISA

XLDnaute Occasionnel
Bonjour Patricktoulou, le forum!
Merci encore pour le pas que vous me faites franchir et surtout pour la promptitude dans les réponses.
Merci
DJISA
 

patricktoulon

XLDnaute Barbatruc
re
de rien
je précise
que copy destination:=.... a pour effet non seulement de copier le formatage mais l'object tableau structuré aussi
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas