XL 2016 D'un formulaire personnalisé vers des feuilles nominatives

M&MSjaune · 10 Février 2022

Bonjour,
à partir d'un formulaire complété en partie par une BDD selon le nom de personnes, je souhaiterai que chaque formulaire créé (par ligne) se copie et aille se ranger dans une feuille au nom de la personne nommée. Donc 1 feuille par personne avec 2, 3, 4... copie de formulaire selon le nombre de lignes occupées par la personne.
ex par rapport au fichier mis en PJ : dans la feuille "FICHE BALISEUR GR et GRP" lorsque je clique sur le bouton de liste en bas à gauche "010" cela génère un formulaire pré-rempli au nom de Fabrice. Je souhaiterai que ce formulaire se copie et aille se ranger dans une feuille "Fabrice". Quand je vais cliquer sur "030" cela va générer autre fiche formulaire au nom de Fabrice, il faudrait qu'elle aille aussi se ranger dans la même feuille "Fabrice". Lorsque j'enverrai sa fiche à Fabrice il aura ainsi toutes ses fiches formulaire sur la même feuille. De même pour les fiches formulaires de la feuille "FICHE BALISEUR PR".
Un petit + : ce serait bien que les feuilles nominatives soient rangées dans l'ordre alphabétique.
Merci de votre aide.

job75 · 13 Février 2022

M&MSjaune à dit:
Est-ce qu'il serait possible que dans chaque fichier nominatif, au lieu d'avoir une feuille avec toutes les fiches, que chacune d'entre-elles soit une feuille ? l'onglet étant au nom du n° de ligne.

Aucun problème, voyez ce fichier (2), ça prend un peu plus de temps ;

VB:

Dim chemin$, nfichier%, nfiche& 'mémorise les variables

Sub CreerFichiers()
'---se lance par le raccourci clavier Ctrl+F---
Dim t#, i%
t = Timer
chemin = ThisWorkbook.Path & "\Fichiers " & Feuil1.[H1] & "\" 'à adapter
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'crée le sous-dossier
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'---ferme tous les fichiers .xlsx ouverts
For i = Workbooks.Count To 1 Step -1
    With Workbooks(i)
        If Right(.Name, 5) = ".xlsx" Then .Close False
    End With
Next
'---crée les fichiers et les fiches---
Creations Feuil1, Feuil2, 7 'attention, mettre les bons CodeNames...
Creations Feuil3, Feuil4, 6 'attention, mettre les bons CodeNames...
'---enregistre et ferme les fichiers--
For i = Workbooks.Count To 1 Step -1
    With Workbooks(i)
        If Right(.Name, 5) = ".xlsx" Then .Close True
    End With
Next i
If nfichier Then MsgBox nfichier & " fichiers nominatifs avec " & nfiche & " fiches créés en " & Format(Timer - t, "0.0 \sec"), , "Création"
nfichier = 0: nfiche = 0 'RAZ
End Sub

Sub Creations(F1 As Worksheet, F2 As Worksheet, colnom%)
Dim c As Range, nom$, w As Worksheet, i%
For Each c In F2.Range("B2:R15")
    If Not c.Locked Then c = "" 'sécurité, vide les cellules déverrouillées
Next c
For Each c In F1.Range("A4", F1.Range("A" & F1.Rows.Count).End(xlUp))
    nom = c(1, colnom)
    If IsNumeric(CStr(c)) And nom <> "" Then
        '---crée le fichier---
        On Error Resume Next
        If IsError(Workbooks(nom)) Then
            On Error GoTo 0
            nfichier = nfichier + 1 'comptage
            Workbooks.Add xlWBATWorksheet 'nouveau document avec 1 feuille
            ActiveWorkbook.SaveAs chemin & nom & ".xlsx", 51 'enregistre au format 51 = .xlsx
        End If
        '---crée la fiche/feuille---
        nfiche = nfiche + 1 'comptage
        F2.Range("C15") = c
        With Workbooks(nom & ".xlsx")
            .Activate
            If .Sheets(1).UsedRange.Count = 1 Then Set w = .Sheets(1) Else Set w = .Sheets.Add(After:=.Sheets(.Sheets.Count))
            w.Name = F1.Name & " ligne " & c
            For i = 1 To 19
                w.Columns(i).ColumnWidth = F2.Columns(i).ColumnWidth 'largeur des colonnes
            Next i
            F2.Rows("1:15").Copy w.Cells(1) 'pour les formats, la ligne 1 évite un problème de bordure
            w.Cells(1).Resize(15, 18) = F2.Range("A1:R15").Value 'copie les valeurs
            w.Cells(15, 3).Validation.Delete 'supprime la liste de validation en C15
            ActiveWindow.DisplayGridlines = False 'masque le quadrillage (facultatif)
            w.Protect "toto" 'mot de passe à adapter
            .Sheets(1).Activate
        End With
    End If
Next c
End Sub

job75 · 13 Février 2022

Il restait à remettre la formule du défraiement en R12; fichier (3) :

VB:

w.Cells(12, 18) = "=R9*0.39" 'formule du défraiement en R12

Bonne nuit.

M&MSjaune · 15 Février 2022

Ça fonctionne très bien !
Bon ben, c'est à moi de travailler maintenant : il faut que j'adapte la macro au "vrai" fichier (120 lignes et 150 lignes) avec 90 personnes. Ce sera ma partie apprentissage. Je m'y colle et je vous tiens au courant. Un grand merci à tous les deux, l'un a commencé, l'autre l'a continué. Vraiment super. à bientôt.
Juste un truc : au début j'ai fait une fausse manoeuvre en faisant Ctrl+f au lieu de Ctrl+F et il m'a semblé que ça téléchargeait mais je ne sais où ? Pas sur téléchargements en tout cas. Qu'en dire ??
M&Ms Jaune.

job75 · 15 Février 2022

Bonjour M&MSjaune,

Dans le fichier que j'ai joint le raccourci clavier est Ctrl+f mais je parle des touches Ctrl+F.

La touche F est toujours une minuscule si la touche Maj n'est pas activée.

A+

M&MSjaune · 3 Mars 2022

Ça y est ! en reparamétrant les feuilles formulaires par rapport au nombre de lignes et au nombre de personnes ça a marché. Peu sûr de moi, à chaque changement de paramètres, je vérifiais le fonctionnement de la macro. C'est un peu long mais ça m'a permis de rectifier de suite quelques plantages de ma part. Même si ça fonctionne (j'en suis hyper-content) il reste quelques zones d'ombre pour moi. Question apprentissage j'avance lentement : dans la macro, que signifie le nombre 51 (ActiveWorkbook.SaveAs chemin & nom & ".xlsx", 51 'enregistre au format 51 = .xlsx) de même pour 19 (For i = 1 To 19) ?
Suite de la demande d'aide
À partir de la même BDD, onglets 1 et 3, je souhaiterai remplir une autre feuille "lettre de mission" avec le nom du baliseur, quelque soit la colonne dans laquelle il est (G;H;I;J onglet GR et GRP ou F;G;H;I onglet PR) avec les sections ou le nom des PR. Comme pour l'autre macro, générer dans un dossier "lettres de mission" une feuille par nom et dans l'ordre alphabétique.
En PJ je remets la BDD avec le formulaire lettre de mission et un formulaire rempli au nom de Fabrice pour exemple de résultat souhaité.
Merci de votre patience et de votre aide,
M&MSjaune

AtTheOne · 3 Mars 2022

Bonjour à toutes & à tous, bonjour @M&MSjaune

M&MSjaune à dit:
que signifie le nombre 51 (ActiveWorkbook.SaveAs chemin & nom & ".xlsx", 51 'enregistre au format 51 = .xlsx)

La réponse est dans la question : 'enregistre au format 51 = .xlsx Il s'agit d'un enregistrement au format xlsx (sans macro)

M&MSjaune à dit:
de même pour 19 (For i = 1 To 19)

19 est le nombre de colonnes de la plage copiée (colonnes A à S)

Je regarde pour la lettre de mission ...
Amicalement
Alain

job75 · 3 Mars 2022

Bonjour M&MSjaune, AtTheOne,

Voyez le fichier joint avec la lettre de mission modèle et le code :

VB:

'---crée la lettre de mission en PDF, enregistre et ferme les fichiers--
For i = Workbooks.Count To 1 Step -1
    With Workbooks(i)
        If Right(.Name, 5) = ".xlsx" Then
            ThisWorkbook.Sheets("LETTRE DE MISSION").Copy 'nouveau document
            Union(Range("A4"), Range("B28")) = .Sheets(1).Range("M2")
            For j = .Sheets.Count To 1 Step -1
                Rows(33).Insert
                Range("B33").HorizontalAlignment = xlCenter
                Range("B33").NumberFormat = "@" 'format Texte
                Range("B33") = .Sheets(j).Range("B7")
                Range("C33").Resize(, 3).Merge 'fusionne
                Range("C33") = .Sheets(j).Range("C9")
                Range("F33").Resize(, 3).Merge 'fusionne
                Range("F33") = .Sheets(j).Range("F9")
            Next j
            With Range("B32").CurrentRegion
                .Borders.Weight = xlThin 'bordures
                .BorderAround Weight:=xlMedium 'pourtour
                .Rows.AutoFit 'ajustement hauteur
            End With
            With ActiveSheet.PageSetup
                .Zoom = False
                .FitToPagesWide = 1 '1 page en largeur
                .FitToPagesTall = 1 '1 page en hauteur
            End With
            ActiveSheet.ExportAsFixedFormat xlTypePDF, chemin & Range("A4") & " Lettre de mission.pdf"
            ActiveWorkbook.Close False
            .Close True
        End If
    End With
Next i

La lettre de mission est créée sous forme de fichier PDF.

A+

AtTheOne · 3 Mars 2022

Bonsoir à toutes & à tous, bonsoir @M&MSjaune

Voilà,
j'ai un peu repris le modèle de lettre essenciellement pour des problèmes de largeur de cellule et pour y créer les noms définis :
"_Prénom_Nom_Lettre", "_Prénom_Nom_Fiche", "_Lst_Missions", "_Début", "_Fin", "_Hauteur_Lignes"
qui pointent respectivement vers :
les deux cases "Prénom et Nom" , la 1ère cellule de la liste des GR PR, la 1ère cellule des débuts de section, la 1ère cellule des fins de section, la première cellule d'une zone qui me sert à ajuster la hauteur des lignes (because cellules fusionnée dans la liste des missions).

Ces noms sont utilisés par la macro "Lettre_Mission".

Le modèle comme les deux autres est intégré dans le classeur.

La macro se lance séparément de la génération des fiches (c'est ce que j'ai cru comprendre dans ta demande) par CTRL+m
Donc je refais la recherche (cette partie est très rapide)

La Macro :

Enrichi (BBcode):

Option Explicit
Option Base 1

Sub Lettre_Mission()
     
     Const Lgn_Déb = 4, Col_Déb = "B"   'Début des données exploitées
     Dim chemin$
     Dim Col_Baliseurs, Col_Infos, i As Long, lgn_Fin As Long, j As Long, k, m As Long
     Dim Dic As New Scripting.Dictionary
     Dim Wsh_GR As Worksheet, Wsh_PR As Worksheet, Wsh_Lettre As Worksheet, Feuilles As Sheets, Sh As Worksheet
     Dim Col_Fin, Clef, Missions, Tb_Missions()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
     chemin = ThisWorkbook.Path & "\Lettres de Mission " & Feuil1.[H1] & "\" 'à adapter
     If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'crée le sous-dossier
     
     Col_Fin = Array("J", "I")                                     'Colonne de fin sur les feuilles
     Col_Baliseurs = Array(Array(6, 7, 8, 9), Array(5, 6, 7, 8))   'N° de colonne dans le tableau VB (commence en "B")
     Col_Infos = Array(Array(1, 3, 4), Array(1, 2))                'N° de colonne dans le tableau VB (commence en "B")
      
     Set Wsh_GR = Feuil1: Set Wsh_PR = Feuil3: Set Wsh_Lettre = Feuil5
     
     Set Feuilles = Sheets(Array(Wsh_GR.Name, Wsh_PR.Name))
     
     ReDim Tb(1 To Feuilles.Count), tb_Temp(1 To Feuilles.Count)
     i = 1
     
     'Constitution de la liste des missions pour chaque baliseurs
     For Each Sh In Feuilles
          
          lgn_Fin = Sh.Range(Col_Déb & Sh.Rows.Count).End(xlUp).Row
          Tb(i) = Sh.Range(Col_Déb & Lgn_Déb, Col_Fin(i) & lgn_Fin).Value
          For j = 1 To UBound(Tb(i), 1)
               For Each k In Col_Baliseurs(i)
                    If Tb(i)(j, k) <> "" Then
                         If Dic.Exists(Tb(i)(j, k)) Then
                              tb_Temp = Dic(Tb(i)(j, k)): tb_Temp(i) = IIf(tb_Temp(i) = "", j, tb_Temp(i) & "¤" & j)
                         Else
                              tb_Temp = Array("", ""): tb_Temp(i) = j
                         End If
                         Dic(Tb(i)(j, k)) = tb_Temp
                    End If
                    
               Next k
          Next j
          i = i + 1
     Next Sh
     
     'Création de la liste des missions, remplissage de la lettre, enregistrement des fichiers
     For Each Clef In Dic
          If Clef <> "" Then
               Erase Tb_Missions
               k = 0
               For i = 1 To UBound(Dic(Clef))
                    If Dic(Clef)(i) <> "" Then
                         Missions = Split(Dic(Clef)(i), "¤")
                         For j = 0 To UBound(Missions)
                              k = k + 1
                              ReDim Preserve Tb_Missions(1 To 3, 1 To k)
                              m = CInt(Missions(j))
                              Tb_Missions(1, k) = Tb(i)(m, Col_Infos(i)(1))
                              Tb_Missions(2, k) = Tb(i)(m, Col_Infos(i)(2))
                              If UBound(Col_Infos(i)) = 3 Then Tb_Missions(3, k) = Tb(i)(m, Col_Infos(i)(3))
                         Next j
                    End If
               Next i
               tb_Temp = WorksheetFunction.Transpose(Tb_Missions)
               Wsh_Lettre.Copy
               Set Sh = ActiveSheet
               Sh.[_Prénom_Nom_Lettre] = Clef
               Sh.[_Prénom_Nom_Fiche] = Clef
               m = UBound(Tb_Missions, 2)
               If m > 1 Then
                    Sh.[_Lst_Missions].Offset(1).EntireRow.Resize(m - 1).Insert Shift:=xlDown
                    Sh.[_Lst_Missions].EntireRow.Copy Sh.[_Lst_Missions].Offset(1).EntireRow.Resize(m - 1)
               End If
               With Sh.[_Hauteur_Lignes].Resize(m, 3)
                    .Value = tb_Temp
                    .EntireRow.AutoFit
               End With
               Sh.[_Lst_Missions].Resize(m).Value = WorksheetFunction.Index(tb_Temp, 0, 1)
               Sh.[_Début].Resize(m).Value = WorksheetFunction.Index(tb_Temp, 0, 2)
               Sh.[_Fin].Resize(m).Value = WorksheetFunction.Index(tb_Temp, 0, 3)
               Sh.[_Hauteur_Lignes].EntireColumn.Resize(, 3).Delete
               Sh.Name = Clef
               Sh.Parent.SaveAs chemin & Clef & ".xlsx", FileFormat:=xlOpenXMLWorkbook
          End If
     Next Clef
     
     'Fermeture des fichiers dans un deuxième temps
     '(car j'ai des problèmes de synchronisation si je le fais dans la foulée)
     For Each Clef In Dic
         Workbooks(Clef & ".xlsx").Close False
     Next Clef
     
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Voir le fichier en pièce jointe
Amicalement
Alain

Ps je viens de voir que je me suis fait griller par @job75, encore une fois je ne pédale pas assez vite !!!
Je regarde tout de suite sa solution ...

AtTheOne · 3 Mars 2022

Bonsoir à toutes & à tous, bonsoir @M&MSjaune & @job75

Bonne idée le pdf et de faire les fiches et les lettres dans une même passe (moi j'avais compris qu'il fallait le faire séparément et dans 2 répertoires, pourquoi ??? va savoir ...)
Par contre j'ai 2 problèmes :

avec office2007 et office2021, pour la ligne : "If IsError(Workbooks(nom)) Then ..."
Workbooks(nom) est systématiquement en erreur car les classeurs s'appellent "nom.xlsx"
je l'ai donc remplacé par "If IsError(Workbooks(nom & "xlsx")) Then .." et là ça dépote ..
Pourquoi n'avez-vous pas cette erreur ?
la macro ne boucle pas sur les 4 colonnes de baliseurs (G,H,I,J) pour GR et (F,G,H,i) pour PR

J'ai remis la fermeture à la suite de la sauvegarde, et je n'ai plus de problème, ça accélère l'exécution.
Je suis absent demain ...
Bonne nuit
Alain

job75 · 3 Mars 2022

Bien d'accord, il vaut mieux écrire IsError(Workbooks(nom & "xlsx"))

Je corrige le fichier du post #22.

Bonne nuit.

AtTheOne · 4 Mars 2022

Bonjour à toutes & à tous, bonjour @M&MSjaune , bonjour @job75.

Je suis matinal ... enfin aujourd'hui !

Bon, bien que cela fasse double emploi avec ta proposition Job75, j'ai repris ma version des fiches baliseur pour respecter les mêmes fonctionnalités que ta version (boucle sur les baliseurs et pour les 2 types de fiches, sauvegarde suivant le même principe).
J'ai laissé 2 macros séparées, par paresse, et aussi pour avoir l’opportunité de les lancer indépendamment l'une de l'autre. Mais j'ai créé une macro qui les appelle successivement, elle réalise ainsi le même travail que tes outils.

Appel des macros :
CTRL+m Création des lettres de mission
CTRL+j Création des fiches baliseur
CTRL+r Enchaînement des 2 macros

Il reste bien sur le CTRL+f pour l'appel de l'outil de Job75

2 différences, je boucle sur les 4 colonnes des baliseurs comme l'a demandé @M&MSjaune :

M&MSjaune à dit:
avec le nom du baliseur, quelque soit la colonne dans laquelle il est (G;H;I;J onglet GR et GRP ou F;G;H;I onglet PR)

et la hauteur des lignes est adaptée aux longs libellés.
Dans ton cas l'autofit ne fonctionne pas sur les cellules fusionnées. (exemple Mireille D.)
Pour régler ce problème j'utilise des cellules non fusionnés faisant à peu près la même largeur que les groupe de cellules fusionnées. Elles sont exclues de la zone d'impression que j'exporte en pdf sur 2 pages.

Dans l'état, les temps d'exécution des deux méthodes sont grosso modo les mêmes sur ma machine.

Voir la PJ
Amicalement
Alain

Maintenant je pars pour la journée ...

M&MSjaune · 4 Mars 2022

Encore une fois merci à tous les deux. J'aime bien la solution qui me permets de choisir le lancement de chaque macro. Par contre je préfèrerait que les fichiers soient générés sous format xlsx car cela me laisse plus facilement la possibilité de corrections manuelles (en cas de modif des données de dernière minute par ex). Très cordialement, Merci. Fabrice.

job75 · 4 Mars 2022

Bonjour M&MSjaune, AtTheOne,

Ma solution du post #22 ne va pas car en effet il faut que les baliseurs accompagnants aient aussi une lettre de mission.

Voyez donc ce fichier (4) et les 2 macros dans Module2 :

VB:

Dim chemin$, nlettre% 'mémorise les variables

Sub CreerLettreMission()
'---se lance par le raccourci clavier Ctrl+L---
Dim t#, i%
t = Timer
chemin = ThisWorkbook.Path & "\Lettres de mission " & Feuil1.[H1] & "\" 'à adapter
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'crée le sous-dossier
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'---ferme tous les fichiers .xlsx ouverts
For i = Workbooks.Count To 1 Step -1
    With Workbooks(i)
        If Right(.Name, 5) = ".xlsx" Then .Close False
    End With
Next
'---crée les lettres de mission---
CreationLettres Feuil1, 7 'attention, mettre les bons CodeNames...
CreationLettres Feuil3, 6 'attention, mettre les bons CodeNames...
'---enregistre et ferme les fichiers--
For i = Workbooks.Count To 1 Step -1
    With Workbooks(i)
        If Right(.Name, 5) = ".xlsx" Then
            .Sheets(1).Protect "toto" 'mot de passe à adapter
            .Close True
        End If
    End With
Next i
If nlettre Then MsgBox nlettre & " lettres créées en " & Format(Timer - t, "0.0 \sec"), , "Création"
nlettre = 0 'RAZ
End Sub

Sub CreationLettres(F As Worksheet, colnom%)
Dim c As Range, i%, nom$, lig&
For Each c In F.Range("A4", F.Range("A" & F.Rows.Count).End(xlUp))
    If IsNumeric(CStr(c)) Then
        For i = 0 To 3 '4 colonnes
            nom = c(1, colnom + i)
            If nom <> "" Then
                '---crée le fichier---
                On Error Resume Next
                If IsError(Workbooks(nom & " Lettre.xlsx")) Then
                    On Error GoTo 0
                    nlettre = nlettre + 1 'comptage
                    ThisWorkbook.Sheets("LETTRE DE MISSION").Copy 'nouveau document
                    ActiveWorkbook.SaveAs chemin & nom & " Lettre.xlsx", 51 'enregistre au format 51 = .xlsx
                End If
                With Workbooks(nom & " Lettre.xlsx").Sheets(1)
                    Union(.Range("A4"), .Range("B28")) = nom
                    lig = .Columns(2).Find("", .Range("B32"), xlValues).Row '1ère ligne vide
                    .Rows(lig).Insert
                    .Rows(lig).RowHeight = 45
                    .Cells(lig, 3).Resize(, 3).Merge 'fusionne
                    .Cells(lig, 6).Resize(, 3).Merge 'fusionne
                    .Cells(lig, 2).Resize(, 7).Font.Bold = False 'non gras
                    .Cells(lig, 2).Resize(, 7).Borders.Weight = xlThin 'bordures
                    .Cells(lig, 2).Resize(, 7).WrapText = True 'renvoi à la ligne
                    .Cells(lig, 2) = c(1, 2)
                    .Cells(lig, 3) = c(1, IIf(colnom = 7, 4, 3))
                    If colnom = 7 Then .Cells(lig, 6) = c(1, 5)
                End With
            End If
        Next i
    End If
Next c
End Sub

Comme demandé j'ai remplacé les fichiers .pdf par des fichiers .xlsx.

A+

M&MSjaune · 4 Mars 2022

Bonsoir Job75, ça fonctionne bien sauf le nom du PR (onglet PR) qui n'apparaît pas. Seul son n° est inscrit. Exemple feuille de Claude.
Bonne soirée.

job75 · 4 Mars 2022

A 20:29 j'ai édité mon post #28, le nom du PR apparaît bien, testez le bon fichier.

XL 2016 D'un formulaire personnalisé vers des feuilles nominatives

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

Pièces jointes

XLDnaute Accro

XLDnaute Barbatruc

Pièces jointes

XLDnaute Accro

Pièces jointes

XLDnaute Accro

Pièces jointes

XLDnaute Barbatruc

XLDnaute Accro

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency