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

XL 2016 créer feuilles depuis table d'entrée puis synthétiser

S

saimone

XLDnaute Nouveau
Bonjour,
J'aimerais ajouter automatiquement des feuilles sur la base d'un modèle, depuis une table d'entrée.


La table d'entrée est nommée form, elle comporte des longueurs depuis la colonne A2 (A3, A4, A5 etc...); largeur depuis B2 (B3, B4, B5 etc...; et épaisseur depuis C2 (C3, C4, C5 etc...)
numéro depuis la colonne D2 (D3; D4; D5 etc...)

Le nombre de ligne est évolutif (40 maximum)

Le modèle comporte des formule ayant besoin des longueurs, largeurs et épaisseurs, il s'appelle mod.


J'aimerais depuis une macro présente sur la table d'entrée pour:
- créer une feuille par ligne ayant pour nom le numéro présent en colonne D, en partant du modèle de base.
- remplir les cellules correspondantes

Egalement, j'aimerais une autre macro synthétisant les éléments des feuilles créées par la première macro; dans la feuille !synthèse

Je vous mets en PJ le fichier de base (base .xlsx) et un fichier d'exemple (resultatsouhaité.xlsx)


D'avance merci pour votre aide
 

Pièces jointes

  • resultatsouhaité.xlsx
    18.7 KB · Affichages: 9
  • base.xlsx
    14 KB · Affichages: 3
Trier par date Trier par votes

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
Bonjour,
A essayer
VB: 
Sub Insere_Feuille()
Dim Wh As Worksheet, Dl As Integer, i As Integer
Set Wh = Worksheets("form"): Dl = Range("D65536").End(xlUp).Row
For i = 2 To Dl
ActiveWorkbook.Sheets.Add after:=ActiveSheet
  
    With ActiveSheet
    .Name = Wh.Range("D" & i).Value
    .Cells(2, 2).Value = Wh.Cells(1, 4)
    .Cells(2, 3).Value = Wh.Cells(1, 1)
    .Cells(2, 4).Value = Wh.Cells(1, 2)
    .Cells(2, 5).Value = Wh.Cells(1, 3)
    .Cells(3, 2).Value = Wh.Cells(i, 4)
    .Cells(3, 3).Value = Wh.Cells(i, 1)
    .Cells(3, 4).Value = Wh.Cells(i, 2)
    .Cells(3, 5).Value = Wh.Cells(i, 3)
  
    End With
Next i
End Sub

ou à partir d'un bouton, comme le fichier retourné

VB: 
Private Sub CommandButton1_Click()
Dim Wh As Worksheet, Dl As Integer, i As Integer
Set Wh = Worksheets("form"): Dl = Range("D65536").End(xlUp).Row
For i = 2 To Dl
ActiveWorkbook.Sheets.Add after:=ActiveSheet
    
    With ActiveSheet
    .Name = Wh.Range("D" & i).Value
    .Cells(2, 2).Value = Wh.Cells(1, 4)
    .Cells(2, 3).Value = Wh.Cells(1, 1)
    .Cells(2, 4).Value = Wh.Cells(1, 2)
    .Cells(2, 5).Value = Wh.Cells(1, 3)
    .Cells(3, 2).Value = Wh.Cells(i, 4)
    .Cells(3, 3).Value = Wh.Cells(i, 1)
    .Cells(3, 4).Value = Wh.Cells(i, 2)
    .Cells(3, 5).Value = Wh.Cells(i, 3)
    
    End With
Next i
End Sub

@+
 

Pièces jointes

  • Copie de resultatsouhaité.xlsm
    24.1 KB · Affichages: 3
Dernière édition:
Vote positif 0 Vote négatif

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
Voilà, tout en un, mais je pourrai pas faire mieux de mon coté

VB: 
Private Sub CommandButton1_Click()
Dim Wh As Worksheet, Wh2 As Worksheet
Dim Dl As Integer, Dl2 As Integer, i As Integer, j As Integer
Set Wh = Worksheets("form"): Set Wh2 = Worksheets("synthese")
Dl = Range("D65536").End(xlUp).Row
For i = 2 To Dl
ActiveWorkbook.Sheets.Add after:=ActiveSheet
    With ActiveSheet
    .Name = Wh.Range("D" & i).Value
    .Cells(2, 2).Value = Wh.Cells(1, 4)
    .Cells(2, 3).Value = Wh.Cells(1, 1)
    .Cells(2, 4).Value = Wh.Cells(1, 2)
    .Cells(2, 5).Value = Wh.Cells(1, 3)
    .Cells(3, 2).Value = Wh.Cells(i, 4)
    .Cells(3, 3).Value = Wh.Cells(i, 1)
    .Cells(3, 4).Value = Wh.Cells(i, 2)
    .Cells(3, 5).Value = Wh.Cells(i, 3)

    .Cells(9, 2) = "Coté"
    .Cells(10, 2) = "Dessus"
    .Cells(11, 2) = "Int Vertical"
    .Cells(12, 2) = "Int Horizontal"
    .Cells(9, 3) = .Cells(3, 3) & .Cells(3, 4)
    .Cells(10, 3) = .Cells(9, 3)
    .Cells(11, 3) = .Cells(3, 4) - .Cells(3, 5)
    .Cells(12, 3) = .Cells(3, 3) - .Cells(3, 5)
    End With
  
Dl2 = Wh2.Range("C65536").End(xlUp).Row
ActiveSheet.Range("B9:C12").Copy Wh2.Range("B" & Dl2 + 1)
Wh2.Range("A" & Dl2 + 1) = ActiveSheet.Name
Next i

Dl2 = Wh2.Range("C65536").End(xlUp).Row
Wh2.Range("C2:C" & Dl2).Cut Wh2.Range("D2")
Wh2.Range("A2:A" & Dl2).Cut Wh2.Range("C2")
End Sub

et le fichier qui va avec,

@+
 

Pièces jointes

  • Copie de resultatsouhaité.xlsm
    26.3 KB · Affichages: 2
Dernière édition:
Vote positif 0 Vote négatif
S

saimone

XLDnaute Nouveau
Un grand merci pour ton aide.

Je suis allé plus loin dans la démarche avec certains de tes éléments, et d'autres glanés sur ce forum et ailleurs.
La création de feuilles supplémentaires fonctionne désormais à merveille.

J'ai cependant du mal à les synthétiser.
En PJ, il y a le fichier fonctionnel comprenant:

- La feuille d'entrée dans laquelle je rentre des dimensions et d'autres paramètres "LISTE"
Depuis cette feuille je peux générer des feuilles sur la base du modèle, puis les supprimer si besoin.

- la feuille modèle qui sera copiée pour les entrées "MODELE"

- la feuille de synthèse dans laquelle je souhaiterais regrouper toutes les feuilles générées. "SYNTH"

Ce que je souhaiterais:

Lorsque je génère des feuilles, j'aimerais que la partie encadrée en bleue de chaque feuille générée soit copiée l'une en dessous de l'autre dans la feuille "SYNTH"

Attention, le nombre et le nom de chaque feuille ne sera jamais le même d'une utilisation à une autre.

D'avance merci pour ton aide
 

Pièces jointes

  • essai 2.xlsm
    72.1 KB · Affichages: 3
Vote positif 0 Vote négatif

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
Bonjour,
A tester à la place de votre code, j'ai modifié mais pas testé

VB: 
Public Sub CreerFeuilles()

    Dim oShModele As Worksheet
    Dim oShListe As Worksheet
    Dim iLigFin As Integer
    Dim iLig As Integer
    Dim oShNew As Worksheet
    Dim sNomOnglet As String
    Dim Derlig As Integer
    Dim Derlign As Integer
   
    Set oShModele = Worksheets("Modele")
    Set oShListe = Worksheets("LISTE")
   
    iLigFin = oShListe.Range("C" & Rows.Count).End(xlUp).Row
   
    For iLig = 2 To iLigFin
        If oShListe.Range("C" & iLig).Value <> "" Then
            sNomOnglet = oShListe.Range("A" & iLig).Value
            If OngletExist(sNomOnglet) Then
                Set oShNew = Worksheets(sNomOnglet)
            Else
                oShModele.Copy after:=Worksheets(Worksheets.Count)
                Worksheets(Worksheets.Count).Name = sNomOnglet
                Set oShNew = Worksheets(Worksheets.Count)
            End If
            oShNew.Range("E2").Value = oShListe.Range("A" & iLig).Value 'repere
            oShNew.Range("B2").Value = oShListe.Range("B" & iLig).Value 'type
            oShNew.Range("B4").Value = oShListe.Range("C" & iLig).Value 'type
            oShNew.Range("C4").Value = oShListe.Range("D" & iLig).Value 'type
            oShNew.Range("D4").Value = oShListe.Range("E" & iLig).Value 'type
            oShNew.Range("C5").Value = oShListe.Range("F" & iLig).Value 'type
            oShNew.Range("G2").Value = oShListe.Range("G" & iLig).Value 'type
            oShNew.Range("G3").Value = oShListe.Range("H" & iLig).Value 'type
            oShNew.Range("G4").Value = oShListe.Range("I" & iLig).Value 'type
        End If

    Derlig = oShModele.Range("B" & Rows.Count).End(xlUp).Row
    Derlign = Worksheets("SYNTH").Range("B" & Rows.Count).End(xlUp).Row
    oShModele.Range("B7:H" & Derlig - 1).Copy Worksheets("SYNTH").Range("B" & Derlign)
       
    Next iLig
   
    'oShListe.Select  'éviter les select et activate
   
    Set oShListe = Nothing
    Set oShModele = Nothing
   
End Sub

@+
 
Dernière édition:
Vote positif 0 Vote négatif
S

saimone

XLDnaute Nouveau
Merci d'avoir regardé.
Lorsque j'exécute le code; il y a un soucis sur cette ligne:

If OngletExist(sNomOnglet) Then

J'ai essayé
If OngletExiste(sNomOnglet) Then

Sans succès.
Faut il remplacer "Ongle"t par "feuille"?
 
Vote positif 0 Vote négatif

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
J'ai pas le souci, par-contre j'avais fait une autre ereur, mais pour moi ça fonctionne bien.

VB: 
Public Sub CreerFeuilles()

    Dim oShModele As Worksheet
    Dim oShListe As Worksheet
    Dim iLigFin As Integer
    Dim iLig As Integer
    Dim oShNew As Worksheet
    Dim sNomOnglet As String
    Dim Derlig As Integer
    Dim Derlign As Integer
    
    Set oShModele = Worksheets("Modele")
    Set oShListe = Worksheets("LISTE")
    iLigFin = oShListe.Range("C" & Rows.Count).End(xlUp).Row
    
    For iLig = 2 To iLigFin
        If oShListe.Range("C" & iLig).Value <> "" Then
            sNomOnglet = oShListe.Range("A" & iLig).Value
            If OngletExist(sNomOnglet) Then
                Set oShNew = Worksheets(sNomOnglet)
            Else
                oShModele.Copy after:=Worksheets(Worksheets.Count)
                Worksheets(Worksheets.Count).Name = sNomOnglet
                Set oShNew = Worksheets(Worksheets.Count)
            End If
            oShNew.Range("E2").Value = oShListe.Range("A" & iLig).Value 'repere
            oShNew.Range("B2").Value = oShListe.Range("B" & iLig).Value 'type
            oShNew.Range("B4").Value = oShListe.Range("C" & iLig).Value 'type
            oShNew.Range("C4").Value = oShListe.Range("D" & iLig).Value 'type
            oShNew.Range("D4").Value = oShListe.Range("E" & iLig).Value 'type
            oShNew.Range("C5").Value = oShListe.Range("F" & iLig).Value 'type
            oShNew.Range("G2").Value = oShListe.Range("G" & iLig).Value 'type
            oShNew.Range("G3").Value = oShListe.Range("H" & iLig).Value 'type
            oShNew.Range("G4").Value = oShListe.Range("I" & iLig).Value 'type
        End If

Derlig = oShModele.Range("B" & Rows.Count).End(xlUp).Row
Derlign = Worksheets("SYNTH").Range("B" & Rows.Count).End(xlUp).Row
oShModele.Range("B7:H" & Derlig - 1).Copy Worksheets("SYNTH").Range("B" & Derlign + 1)
        
    Next iLig
    
    Set oShListe = Nothing
    Set oShModele = Nothing
    
End Sub
 

Pièces jointes

  • essai 2.xlsm
    56.2 KB · Affichages: 4
Vote positif 0 Vote négatif
S

saimone

XLDnaute Nouveau
Effectivement ça fonctionne !!!
Un grand merci à toi.

Juste un dernier point, est il possible de recopier les valeurs des cellules et non les formules?
Dans l'état, il y a des erreurs de référence.
 
Vote positif 0 Vote négatif
S

saimone

XLDnaute Nouveau
Pas vraiment
Dans les feuilles générées, les valeurs des cellules sont bonnes (certaines comprennent des formules).
Il n'y a aucune erreur manquante créant une #valeur!

L'erreur vient lors de la copie dans la feuille de synthèse.

Je n'ai par contre aucune idée de comment contourner ce problème
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Résolu(e)
Microsoft 365 Extraction d'informations sur différents onglets en partant d'une base de données
Réponses
7
Affichages
489
MBax
S
  • Résolu(e)
Microsoft 365 - Conseils pour la structuration d'une base de données -
2 3
Réponses
44
Affichages
3 K
crocrocro
C
Q
  • Question
Microsoft 365 Créer un formulaire pour duplication d'onglet avec tableau
Réponses
6
Affichages
460
job75
B
  • Question
XL 2013 Export Base de donnée biodiversité et créer tableau synthèse
Réponses
3
Affichages
501
chris
L
  • Question
Microsoft 365 Faire agir une macro en fonction de l'emplacement du bouton
Réponses
2
Affichages
303
AtTheOne
  • Question
Microsoft 365 Comment générer une table de synthèse s'appuyant sur plusieurs tdyn ?
Réponses
2
Affichages
737
chris
B
  • Question
XL 2016 Macro BVA pour créer une synthèse à partir de plusieurs onglets Excel
Réponses
6
Affichages
831
bnolwalid
B
V
  • Résolu(e)
XL 2016 Facturier : Retour à la ligne sur la facture
2
Réponses
19
Affichages
960
Vermithor
V
M
  • Résolu(e)
XL 2019 Synthèse d'un registre annuel
Réponses
4
Affichages
1 K
gbinforme
G
B
  • Résolu(e)
Microsoft 365 Challenge : rechercher plusieurs valeurs (plage) dans plusieurs feuilles et les reporter dans une feuille synthèse (selon une référence)
2
Réponses
18
Affichages
2 K
Bastien43
B
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…