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.

AtTheOne · 11 Février 2022

Bonjour à tous, bonjour @M&MSjaune

Peux-tu renvoyer un fichier dont les feuilles ne sont pas protégée ?

A bientôt
Alain

job75 · 11 Février 2022

Bonsoir M&MSjaune, AtTheOne,

AtTheOne à dit:
Peux-tu renvoyer un fichier dont les feuilles ne sont pas protégée ?

Il semble que les protections ne soient pas gênantes puisque les cellules à remplir sont déverrouillées.

A+

AtTheOne · 11 Février 2022

Bonsoir @job75,
Oui mais il y a une correction de formule à faire (adresse relative à passer en adresse absolue, car cela gêne lorsque la copie est décalée dans la feuille cible)
Mais je peux me débrouiller avec des collages spéciaux successifs ...
A+
Alain

AtTheOne · 11 Février 2022

Re à Tous

Ci-Joint une solution avec "ton petit plus":

M&MSjaune à dit:
Un petit + : ce serait bien que les feuilles nominatives soient rangées dans l'ordre alphabétique.

Le code des deux feuilles concernées sur l'événement Change :

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
   
     Application.ScreenUpdating = False
     If Target.Address = "$C$15" Then Record_Fiche Me
     Application.ScreenUpdating = True
   
End Sub

La macro de remplissage :

Code:

Sub Record_Fiche(WshSource As Worksheet)
    
     Dim Wsh_Cible As Worksheet, Nom As String, idx As Byte, nbSh As Byte, i As Byte, LgnPaste As Long, Tb_Sh()
    
     On Error Resume Next
     Nom = WshSource.[M2].Value
     If Nom = "" Then Exit Sub
    
     Set Wsh_Cible = Worksheets(Nom)
     On Error GoTo 0
     If Wsh_Cible Is Nothing Then
          'Créer la feuille
          '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
          Worksheets.Add after:=Worksheets("LISTE RÉFÉRENTS")
          Set Wsh_Cible = ActiveSheet
          Wsh_Cible.Name = Nom
         
          'Tri dans l'ordre alphabétique des noms de feuille
          '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
          idx = Wsh_Cible.Index
          nbSh = Worksheets.Count - idx + 1
          ReDim Tb_Sh(1 To nbSh)
          For i = 1 To nbSh
               Tb_Sh(i) = Worksheets(i + idx - 1).Name
          Next
          tri Tb_Sh, LBound(Tb_Sh), UBound(Tb_Sh)
          For i = 1 To nbSh
               Worksheets(Tb_Sh(i)).Move after:=Worksheets(idx + i - 1)
          Next
         '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
          ActiveWindow.DisplayGridlines = False    'Pas de cadrillage
          WshSource.Activate                       'Retour sur la feuille source
          WshSource.Columns("A:S").Copy
          Wsh_Cible.Columns("A:S").PasteSpecial xlPasteColumnWidths 'Copier la largeur des colonnes
     End If
     With Wsh_Cible
          LgnPaste = .Cells(.Rows.Count, 3).End(xlUp).Row
          LgnPaste = LgnPaste + Abs(LgnPaste > 1)     'N° de la ligne cible de la copie
     End With
     WshSource.Rows("1:11").Copy
     Wsh_Cible.Rows(LgnPaste).Resize(11).PasteSpecial xlPasteValues    'D'abord collage des valeurs
     Wsh_Cible.Rows(LgnPaste).Resize(11).PasteSpecial xlPasteFormats   'Puis collage des formats
     WshSource.Rows("12:15").Copy Destination:=Wsh_Cible.Rows(LgnPaste + 11).Resize(4) 'Pour cette partie de la fiche on garde les formaules
     Application.CutCopyMode = False
     WshSource.[C15].Activate
        
End Sub

La macro de tri du regretté Jacques BOISGONTIER

Code:

Sub tri(a, gauc, droi) ' Quick sort J.BOISGONTIER
  ref = a((gauc + droi) \ 2)
  g = gauc: d = droi
  Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
       temp = a(g): a(g) = a(d): a(d) = temp
       g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call tri(a, g, droi)
  If gauc < d Then Call tri(a, gauc, d)
End Sub

Le tout dans le classeur joint.

Bonne soirée à tous
Amicalement
Alain

job75 · 12 Février 2022

Bonsoir M&MSjaune, AtTheOne,

Créer une feuille nominative et/ou une fiche chaque fois que les cellules C15 sont renseignées me paraît une solution bancale.

En effet a ce moment-là il y a des cellules pas encore renseignées.

Il faudrait donc un bouton pour créer la fiche une fois les cellules remplies.

La macro devra créer la fiche mais aussi la modifier si elle est déjà créée.

Il faudra donc pouvoir repérer la fiche, sans doute par un numéro unique.

A+

M&MSjaune · 12 Février 2022

OUAAAH ! super ! merci beaucoup AtTheOne exactement ce qu'il me fallait !
D'une part j'ai mon outil de gestion, d'autre part la rédaction des codes (pas trop volumineuse) va me permettre d'essayer d'y rentrer pour ma formation perso.
Pour job75:
...Créer une feuille nominative et/ou une fiche chaque fois que les cellules C15 sont renseignées me paraît une solution bancale.

En effet a ce moment-là il y a des cellules pas encore renseignées...
Justement, cela me permet ensuite d'enregistrer chaque fiche dans des dossiers nominatifs dans mon drive à destination des intéressés qui ouvrirons leur dossier (contenant aussi d'autres fichiers) et qui rempliront leur formulaire en ligne, ou bien le téléchargeront pour me le renvoyer ensuite une fois complété (ils ne sont pas tous à l'aise même avec des procédures simples).
Du coup, il reste un petit défaut : ce serait mieux si les cellules restaient protégées, hormis celles que j'avais laissées à compléter. Cette protection évite toutes modifications ou fausse manœuvre de la part des baliseurs, et ils en sont TRÈS capables. Est-ce possible d'y remédier, je ne me vois pas reprendre chaque fiche pour remettre une protection.
Si cela peut aider je remets en PJ le fichier sans les protections.
Un grand merci encore pour ces heures tardives occupées pour m'aider.
M&MSjaune
ps: cellules à laisser dévérouillées : P4; J9 à R9; B13; C15.

job75 · 12 Février 2022

Ah d'accord, j'avais mal compris, les cellules vides de chaque fiche ne doivent pas être remplies.

C'est au destinataire de le faire.

Mais alors pourquoi ne pas créer toutes les feuilles et toutes les fiches en même temps ?

Dans la macro il y aura une boucle pour renseigner la cellule C15 des 2 feuilles sources.

AtTheOne · 12 Février 2022

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

Remarque :

Dans la copie des fiches sur les feuilles Baliseurs toutes les formules sauf celle de l'indemnité km sont remplacées par leur valeur lors de la copie.

A mon sens sur cette copie il ne faudrait pas que le N° de ligne (correspondant à C15) soit modifiable.

Je suis quand même d'accord avec Job75, la génération d'une fiche peut être accidentelle en glissant d'un N° à l'autre, je pense qu'il serait mieux de partir des onglets "GR et GRP" et "PR" où tu as une vue plus globale. On peut imaginer un double-clic ou un clic droit sur le N° avec quelques vérifications pour assurer le coup.
A toi de voir.

Pour la protection si tu veux un mot de passe il faudra changer celui que je vais mettre. (Sans doute le même que pour les feuilles "GR et GRP" et "PR".)

On peut imaginer une liste des baliseurs avec le chemin de leur dossier personnel et une macro qui vient lire cette liste et fait le transfert.

J'ai modifié les formules des fiches après avoir créé 2 noms "_Lst_GRetGRP" et "_Lst_PR" qui renvoient aux deux plages de tes feuilles source. Cela me permet de faire des collages directs qui embarquent toute la mise en forme et l'attribut Verrouillé ou non des cellules. J'y ai glissé une gestion des erreurs.
Ensuite je remplace les formules par leur valeur sauf pour l'indemnité km que je remets et je verrouille le N° de ligne.

Voilà le code modifié de la macro de remplissage :

VB:

Sub Record_Fiche(WshSource As Worksheet)
    '__________________________________________________________________________
     Const MdP As String = "MotDePasseProvisoire"      'Mot de passe à modifier
    '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
     Dim Wsh_Cible As Worksheet, Nom As String, idx As Byte, nbSh As Byte, i As Byte, LgnPaste As Long, Tb_Sh()
    
     On Error Resume Next
     Nom = WshSource.[M2].Value
     If Nom = "" Then Exit Sub
    
     Set Wsh_Cible = Worksheets(Nom)
     On Error GoTo 0
     If Wsh_Cible Is Nothing Then
          'Créer la feuille
          '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
          Worksheets.Add after:=Worksheets("LISTE RÉFÉRENTS")
          Set Wsh_Cible = ActiveSheet
          Wsh_Cible.Name = Nom
          Wsh_Cible.Protect Password:=MdP
          'Tri dans l'ordre alphabétique des noms de feuille
          '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
          idx = Wsh_Cible.Index
          nbSh = Worksheets.Count - idx + 1
          ReDim Tb_Sh(1 To nbSh)
          For i = 1 To nbSh
               Tb_Sh(i) = Worksheets(i + idx - 1).Name
          Next
          tri Tb_Sh, LBound(Tb_Sh), UBound(Tb_Sh)
          For i = 1 To nbSh
               Worksheets(Tb_Sh(i)).Move after:=Worksheets(idx + i - 1)
          Next
         '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
          ActiveWindow.DisplayGridlines = False    'Pas de cadrillage
          WshSource.Activate                       'Retour sur la feuille source
          WshSource.Columns("A:S").Copy
          Wsh_Cible.Columns("A:S").PasteSpecial xlPasteColumnWidths 'Copier la largeur des colonnes
     End If
     With Wsh_Cible
          Wsh_Cible.Unprotect Password:=MdP
          LgnPaste = .Cells(.Rows.Count, 3).End(xlUp).Row
          LgnPaste = LgnPaste + Abs(LgnPaste > 1)     'N° de la ligne cible de la copie
     End With
     'Ces oprérations se font en relatif par rapport à la ligne LgnPaste :
     WshSource.Rows("1:15").Copy Destination:=Wsh_Cible.Rows(LgnPaste) 'Copie de la plage Source
     FormuleR1C1 = Wsh_Cible.Rows(LgnPaste).Range("R12").FormulaR1C1   'Récupération de la formule Indemnité km
     Wsh_Cible.Rows(LgnPaste).Range("A1:R15").Value = Wsh_Cible.Rows(LgnPaste).Range("A1:R15").Value 'Transformer toutes les formules en valeur
     Wsh_Cible.Rows(LgnPaste).Range("R12").FormulaR1C1 = FormuleR1C1   'Remettre la formule d'indemnité km
     Wsh_Cible.Rows(LgnPaste).Range("C15").Validation.Delete           'Suppresion de la validation du N° de ligne
     Wsh_Cible.Rows(LgnPaste).Range("C15").Locked = True               'Vérouillage du N° de ligne
     Wsh_Cible.Protect Password:=MdP                                   'Remettre le mot de passe
     Application.CutCopyMode = False
     WshSource.[C15].Activate
        
End Sub

Voir le fichier joint
A bientôt pour un retour ...
Amicalement
Alain

AtTheOne · 12 Février 2022

Salut tout le monde
Je suis resté bloqué (cause bricolage) pendant un peu longtemps et je n'ai vu le post de Job75 qu'après avoir envoyé le mien.

job75 à dit:
Mais alors pourquoi ne pas créer toutes les feuilles et toutes les fiches en même temps ?

C'est un peu dans l'esprit de

AtTheOne à dit:
On peut imaginer une liste des baliseurs avec le chemin de leur dossier personnel et une macro qui vient lire cette liste et fait le transfert.

En allant jusqu'au transfert dans les dossiers personnels...
Bonne soirée, je retourne à mes pinceaux !

job75 · 12 Février 2022

job75 à dit:
Mais alors pourquoi ne pas créer toutes les feuilles et toutes les fiches en même temps ?

Donc voyez le fichier joint et ce code qui crée toutes les fiches en même temps :

VB:

Sub CreerFiches()
'---se lance par le raccourci clavier Ctrl+F---
If MsgBox("Toutes les feuilles à partir de la 6ème seront supprimées..." & vbLf & "Voulez-vous continuer ?", vbYesNo + vbExclamation, "Création des fiches") = vbNo Then Exit Sub
Dim F As Object, i%
Set F = ActiveSheet
Application.ScreenUpdating = False
'---RAZ---
Application.DisplayAlerts = False
For i = Sheets.Count To 6 Step -1
    Sheets(i).Delete
Next
'---crée les feuilles et les fiches---
Creations Feuil1, Feuil2, 7 'attention, mettre les bons CodeNames...
Creations Feuil3, Feuil4, 6 'attention, mettre les bons CodeNames...
'---protège les feuilles créées---
For i = 6 To Sheets.Count
    Sheets(i).Protect "toto" 'mot de passe à adapter
Next i
F.Activate
End Sub

Sub Creations(F1 As Worksheet, F2 As Worksheet, colnom%)
Dim c As Range, nom$, i%, lig&
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 la feuille---
        On Error Resume Next
        If IsError(Sheets(nom)) Then
            On Error GoTo 0
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = nom
            nom = LCase(nom)
            For i = 6 To Sheets.Count
                If nom < LCase(Sheets(i).Name) Then ActiveSheet.Move Before:=Sheets(i): Exit For 'classement
            Next i
            For i = 1 To 19
                Columns(i).ColumnWidth = F2.Columns(i).ColumnWidth 'largeur des colonnes
            Next i
            ActiveWindow.DisplayGridlines = False 'masque le quadrillage (facultatif)
        End If
        '---crée la fiche---
        F2.Range("C15") = c
        With Sheets(nom)
            lig = .Range("C" & .Rows.Count).End(xlUp).Row + 2
            If lig = 3 Then lig = 2
            F2.Rows("2:15").Copy .Cells(lig, 1) 'pour les formats
            .Cells(lig, 2).Resize(14, 17) = F2.Range("B2:R15").Value 'copie les valeurs
            With .Cells(lig, 7).Borders(xlEdgeTop) 'car chez moi cette bordure ne veut pas se copier
                .LineStyle = xlDouble
                .Color = RGB(47, 117, 181) 'bleu
            End With
            .Cells(lig + 13, 3).Validation.Delete 'supprime la liste de validation
        End With
    End If
Next c
End Sub

La macro se lance par le raccourci clavier Ctrl+F.

Toutes les feuilles créées sont protégées avec le mot de passe toto, à adapter.

job75 · 13 Février 2022

Bonjour M&MSjaune, AtTheOne, le forum,

En copiant aussi la ligne 1 du tableau on évite le problème de bordure en G2, c'est plus simple, fichier (2).

A+

AtTheOne · 13 Février 2022

Bonjour à tous,
J'ai eu le même problème et j'ai adopté la même solution ...
A+
Alain

job75 · 13 Février 2022

Puisqu'il faut envoyer des fichiers aux destinataires mieux vaut les créer à la place des feuilles.

Ce n'est guère plus compliqué mais ça prend 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...
'---protège les feuilles créées, 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 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$, i%, lig&
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
            ActiveSheet.Name = Left(nom, 31)
            For i = 1 To 19
                Columns(i).ColumnWidth = F2.Columns(i).ColumnWidth 'largeur des colonnes
            Next i
            ActiveWindow.DisplayGridlines = False 'masque le quadrillage (facultatif)
        End If
        '---crée la fiche---
        nfiche = nfiche + 1 'comptage
        F2.Range("C15") = c
        With Workbooks(nom & ".xlsx").Sheets(1)
            lig = .Range("C" & .Rows.Count).End(xlUp).Row + 1
            If lig = 2 Then lig = 1
            F2.Rows("1:15").Copy .Cells(lig, 1) 'pour les formats, la ligne 1 évite un problème de bordure
            .Cells(lig, 1).Resize(15, 18) = F2.Range("A1:R15").Value 'copie les valeurs
            .Cells(lig + 14, 3).Validation.Delete 'supprime la liste de validation
        End With
    End If
Next c
End Sub

Les fichiers .xlsx créés sont dans le sous-dossier Fichiers 2022.

M&MSjaune · 13 Février 2022

En regardant vos propositions, job75 et AtTheOne, j'ai vraiment la tête de mon M&Ms !
Je suis béat d'admiration. Je ne pensais pas que la dernière proposition de job75 soit possible, c'est la raison pour laquelle j'avais envisagé de passer par le bouton de liste (pré-remplissage nominatif) puis par le tri et rassemblement des fiches par nom et par feuille, etc... enfin bon une stratégie simpliste de ma part. Même si la fiche formulaire est ce que je souhaite dans sa forme.

Je me rends compte que les possibilités d'excel dépassent ma représentation de son possible.
Le fait de passer des deux feuilles de BDD (PR et GR/GRP) directement à la création de fichiers me semble effectivement bien plus pratique, ça m'arrange pas mal. Du coup, je deviens gourmand ? 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.
En tout cas, merci à vous deux ça marche déjà vachement bien.
M&Ms Jaune.

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

M&MSjaune

XLDnaute Nouveau

Pièces jointes

AtTheOne

XLDnaute Accro

job75

XLDnaute Barbatruc

AtTheOne

XLDnaute Accro

AtTheOne

XLDnaute Accro

Pièces jointes

job75

XLDnaute Barbatruc

M&MSjaune

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

AtTheOne

XLDnaute Accro

Pièces jointes

AtTheOne

XLDnaute Accro

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

AtTheOne

XLDnaute Accro

job75

XLDnaute Barbatruc

Pièces jointes

M&MSjaune

XLDnaute Nouveau

Discussions similaires