XL 2016 Modifier une base de données, sans user form, VBA

[erogaki]

Bonjour, je n'ai pas de connaissance solide en macro VBA.

J'ai créé un formulaire avec des macros

• une pour enregistrer mon formulaire dans une base de données, avec un n° de fiche
• une pour afficher un formulaire qui a été enregistré dans la BDD grâce au n° de fiche
• une pour obtenir un formulaire vierge
• une pour générer un PDF

Je souhaiterais créer une macro supplémentaire qui me permettrait une fois un formulaire affiché, de le modifier et d'enregistrer les modifications apportées dans la BDD. Mais je ne parviens pas à trouver le code ^^'

Je vous joins mon doc à toutes fins utiles…

En espérant que quelqu'un puisse me débloquer, merci pour votre aide

 

[AtTheOne]

Bonsoir à toutes & à tous, bonsoir @erogaki
Ton problème n'a pas passionné les foules ...
Si c'est toujours d'actualité, voilà une solution que je te propose.
Tout d'abord un UserForm serait plus adapté il me semble, mais je respecte ton choix.

Remarques :

• Pour modifier une cellule ou une plage de cellule en VBA, pas la peine de la sélectionner (ça ralenti l’exécution et alourdit la programmation.
• Il vaut mieux nommer les cellules (ou les plage) que l'on manipule dans VBA (pas besoin de revenir sur le code si on insère ou supprime des cellules, des lignes des colonnes.

J'ai donc créé des noms pour tous les champs de la fiche.
Je n'ai conservé qu'un seul bouton dont le texte change suivant le contexte (Formule en H2 sous le bouton)
En haut de la fiche une ligne de message conditionnel s'affiche (ou pas) en fonction du contexte :

J'ai utiliser l'événement Worksheet_Change pour afficher le contenu d'une fiche dès que l'on tape son N°

1. Taper un N° valide dans N° de fiche entraîne l'affichage de la fiche et la modification du bouton qui propose la génération du PDF
2. Modifier une valeur de la fiche courante entraîne la modification du Bouton qui propose l'enregistrement des modifications.
3. Taper un N° invalide Entraîne un passage au rouge, le message "N° de Fiche absent de la base", le vidage des champs de la fiche, la modification du bouton en "En attente ..."
4. Supprimer le N° entraîne le vidage des champs de la fiche et la modification du bouton en "En attente ..."
5. Laisser le N° de fiche vide et saisir au moins la date, le nom la zone entraîne la modification du bouton qui propose l'enregistrement d'une nouvelle fiche.

J'ai modifié le nom de code (VBA) des feuilles Fiches : ShFiches au lieu de Feuil7, Paramètres : ShParam au lieu de Feuil1
Le code des macros se trouve dans le Module MdlAtTheOne, et dans le code de ShFiches
ShFiches :

Private Sub Worksheet_Change(ByVal Target As Range)

     Dim TbdD, Ligne As Long
  
     If Target.Address = Me.[N°].Address Then
          TbdD = Me.[TBDD19]
          Ligne = N°Ligne(Me, TbdD, Target)
          If Ligne > 0 Then
               RemplirFiche Me, TbdD, Ligne
          Else
               ViderFiche Me
          End If
     End If
  
End Sub

MdlAtTheOne

Sub AppelMacro_Clic()
     'Macros associé au bouton AppelMacro
  
     Dim Choix$
     Choix = ""
     On Error Resume Next
     Choix = ShFiches.Shapes(Application.Caller).DrawingObject.Caption
     On Error GoTo 0
     Select Case Choix
        
          Case "", "En attente ..."
               Exit Sub
        
          Case "Générer un PDF de la fiche " & ShFiches.[N°]
               PdfFiche
            
          Case "Enregistrer la nouvelle Fiche"
               NouvelleFiche
        
          Case "Enregistrer les modifications de la fiche " & ShFiches.[N°]
               ModifFiche
            
          Case Else
               MsgBox Choix
  
     End Select
End Sub

Function N°Ligne(Wsh As Worksheet, TbdD, NumFiche As Range) As Long
     'Renvoie le N° de ligne dans le tableau TBdD de la fiche en cours
    
     N°Ligne = 0
     On Error Resume Next
     'Recherche du N° de ligne de la fiche "N°" dans 1ère colonne de la base
     N°Ligne = WorksheetFunction.Match(Wsh.[N°], WorksheetFunction.Index(TbdD, 0, 1), 0)
     On Error GoTo 0
  
End Function

Sub Afficher_Fiche()
     'Affiche la fiche "N°"
  
     Dim Wsh As Worksheet, TbdD, Ligne As Long
     Set Wsh = ShFiches
     'Tableau des données de la BdD
     TbdD = Wsh.[TBDD19]
     'Recherche du N° de ligne de la fiche en cours
     Ligne = N°Ligne(Wsh, TbdD, Wsh.[N°])
     If Ligne < 1 Then MsgBox "Veuillez renseigner un N° de Fiche valide": Exit Sub
  
     RemplirFiche Wsh, TbdD, Ligne
  
End Sub

Sub RemplirFiche(Wsh As Worksheet, TbdD, Ligne As Long)
     'Remplit la fiche avec les éléments de la ligne "Ligne" de la BdD
  
     Application.EnableEvents = False
     With Wsh
          .[DateFiche] = TbdD(Ligne, 3)
          .[NomPrénom] = TbdD(Ligne, 4)
          .[Zone] = TbdD(Ligne, 2)
        
          .[EPI_1 Obs] = TbdD(Ligne, 5)
          .[EPI_2 Obs] = TbdD(Ligne, 6)
          .[EPI_3 Obs] = TbdD(Ligne, 7)
          .[EPI_4 Obs] = TbdD(Ligne, 8)
        
          .[Gen_1 Obs] = TbdD(Ligne, 9)
          .[Gen_2 Obs] = TbdD(Ligne, 10)
          .[Gen_3 Obs] = TbdD(Ligne, 11)
          .[Gen_4 Obs] = TbdD(Ligne, 12)
          .[Gen_5 Obs] = TbdD(Ligne, 13)
          .[Gen_6 Obs] = TbdD(Ligne, 14)
          .[Gen_7 Obs] = TbdD(Ligne, 15)
        
          .[PI_1 Obs] = TbdD(Ligne, 16)
          .[PI_2 Obs] = TbdD(Ligne, 17)
          .[PI_3 Obs] = TbdD(Ligne, 18)
          .[PI_4 Obs] = TbdD(Ligne, 19)
          .[PI_5 Obs] = TbdD(Ligne, 20)
          .[PI_6 Obs] = TbdD(Ligne, 21)
          .[PI_7 Obs] = TbdD(Ligne, 22)
      
          .[A_Rmq] = TbdD(Ligne, 27)
          .[Spé_1] = TbdD(Ligne, 23)
          .[Spé_2] = TbdD(Ligne, 24)
          .[Spé_3] = TbdD(Ligne, 25)
          .[Spé_4] = TbdD(Ligne, 26)
     End With
     Application.EnableEvents = True
  
End Sub

Sub ViderFiche(Wsh As Worksheet)
     'Vider les champs de la fiche à l'exception du N°
  
     Application.EnableEvents = False
     With Wsh
          .[DateFiche].MergeArea.ClearContents
          .[NomPrénom].MergeArea.ClearContents
          .[Zone].MergeArea.ClearContents
        
          .[EPI_1 Obs].ClearContents
          .[EPI_2 Obs].ClearContents
          .[EPI_3 Obs].ClearContents
          .[EPI_4 Obs].ClearContents
        
          .[Gen_1 Obs].ClearContents
          .[Gen_2 Obs].ClearContents
          .[Gen_3 Obs].ClearContents
          .[Gen_4 Obs].ClearContents
          .[Gen_5 Obs].ClearContents
          .[Gen_6 Obs].ClearContents
          .[Gen_7 Obs].ClearContents
        
          .[PI_1 Obs].ClearContents
          .[PI_2 Obs].ClearContents
          .[PI_3 Obs].ClearContents
          .[PI_4 Obs].ClearContents
          .[PI_5 Obs].ClearContents
          .[PI_6 Obs].ClearContents
          .[PI_7 Obs].ClearContents
      
          .[A_Rmq].MergeArea.ClearContents
          .[Spé_1].MergeArea.ClearContents
          .[Spé_2].MergeArea.ClearContents
          .[Spé_3].MergeArea.ClearContents
          .[Spé_4].MergeArea.ClearContents
     End With
     Application.EnableEvents = True
  
End Sub

Sub NouvelleFiche()
     'Ajouter une fiche à la BdD

     Dim Wsh As Worksheet, Ligne As Long
     Set Wsh = ShFiches
     With Wsh
          N° = WorksheetFunction.Max(WorksheetFunction.Index(.[TBDD19], 0, 1)) + 1 'Nouveau N° de Fiche
        
          Application.EnableEvents = False
          .[N°] = N°
          If N° > 1 Then .ListObjects("TBDD19").ListRows.Add 'Ajouter une ligne si la BdD n'est pas vide
          Application.EnableEvents = True
        
          Ligne = .[TBDD19].Rows.Count
          EnregistrerFiche Wsh, .[TBDD19], Ligne
     End With
  
End Sub

Sub ModifFiche()

     Dim Wsh As Worksheet, TbdD, Ligne As Long
     Set Wsh = ShFiches
     TbdD = Wsh.[TBDD19]
     Ligne = N°Ligne(Wsh, TbdD, Wsh.[N°])
     EnregistrerFiche Wsh, Wsh.[TBDD19], Ligne
  
End Sub

Sub EnregistrerFiche(Wsh As Worksheet, LORg As Range, N°Ligne As Long)
     'Enregistrer la fiche courante dans la BdD (au N° de Ligne indiqué)
  
     ReDim TbRés(1 To 1, 1 To LORg.Columns.Count) 'Tableau 1 ligne pour stocker les infos puis les écrire à la ligne N°Ligne
     With Wsh
          TbRés(1, 1) = .[N°]
          TbRés(1, 3) = .[DateFiche]
          TbRés(1, 4) = .[NomPrénom]
          TbRés(1, 2) = .[Zone]
        
          TbRés(1, 5) = .[EPI_1 Obs].Cells(1)
          TbRés(1, 6) = .[EPI_2 Obs].Cells(1)
          TbRés(1, 7) = .[EPI_3 Obs].Cells(1)
          TbRés(1, 8) = .[EPI_4 Obs].Cells(1)
        
          TbRés(1, 9) = .[Gen_1 Obs].Cells(1)
          TbRés(1, 10) = .[Gen_2 Obs].Cells(1)
          TbRés(1, 11) = .[Gen_3 Obs].Cells(1)
          TbRés(1, 12) = .[Gen_4 Obs].Cells(1)
          TbRés(1, 13) = .[Gen_5 Obs].Cells(1)
          TbRés(1, 14) = .[Gen_6 Obs].Cells(1)
          TbRés(1, 15) = .[Gen_7 Obs].Cells(1)
        
          TbRés(1, 16) = .[PI_1 Obs].Cells(1)
          TbRés(1, 17) = .[PI_2 Obs].Cells(1)
          TbRés(1, 18) = .[PI_3 Obs].Cells(1)
          TbRés(1, 19) = .[PI_4 Obs].Cells(1)
          TbRés(1, 20) = .[PI_5 Obs].Cells(1)
          TbRés(1, 21) = .[PI_6 Obs].Cells(1)
          TbRés(1, 22) = .[PI_7 Obs].Cells(1)
      
          TbRés(1, 27) = .[A_Rmq]
          TbRés(1, 23) = .[Spé_1]
          TbRés(1, 24) = .[Spé_2]
          TbRés(1, 25) = .[Spé_3]
          TbRés(1, 26) = .[Spé_4]
     End With
     Application.EnableEvents = False
     LORg.Rows(N°Ligne).Value = TbRés      'Ecrire les infos dans la BdD à la ligne N°Ligne
     Application.EnableEvents = True

End Sub

Sub PdfFiche()
     'Génère le pdf de la fiche en cours

     Dim NomFich$, ZImp$
     With ShFiches
          ZImp = .[Fiche].Address
          With .PageSetup
               'Zone d'impression de la fiche d inspection
               .PrintArea = ZImp
               .Zoom = False
               'Ajustement à 1 page
               .FitToPagesWide = 1
               .FitToPagesTall = 1
               'Centrage
               .CenterHorizontally = True
               .CenterVertically = False
               .Orientation = xlPortrait                            'Portrait
               'Réglage des marges
               .LeftMargin = Application.CentimetersToPoints(0.5)   'Marge gauche 5mm
               .RightMargin = Application.CentimetersToPoints(0.5)  'Marge droite 5mm
               .TopMargin = Application.CentimetersToPoints(0.5)    'Marge haut de page 5mm
               .BottomMargin = Application.CentimetersToPoints(0.5) 'Marge bas de page 5mm
          End With
          NomFich = ThisWorkbook.Path & "\Fiche d'inspection N°" & .[N°] & ".pdf"   'Nom du fichier produit
          MsgBox "Génération du fichier pdf" & Chr(10) & NomFich
          'Génération du fichier pdf
          .[Fiche].ExportAsFixedFormat Type:=xlTypePDF, _
                                      Filename:=NomFich, _
                                      Quality:=xlQualityStandard, _
                                      IncludeDocProperties:=False, _
                                      IgnorePrintAreas:=False, _
                                      OpenAfterPublish:=True
                                    
          MsgBox "Penser à imprimer le fichier générer"
     End With
End Sub

Voilà pour le VBA
Regarde et essaie le fichier joint

Amicalement
Alain

 

[AL 22]

Bonjour erogaki, AtTheOne, le forum,

Intervention qui n'a rien à voir avec la résolution de ce post (désolé), mais plutôt une curiosité personnelle à l'attention de AtTheOne.

Comment arrivez-vous à mettre les commentaires de vos codes en italique ?
Il est facile de changer dans les options de l'éditeur de format du code le type et la couleur de la police, mais c'est tout ! Alors comment procédez-vous ?
En tout cas, bravo pour vos codes et votre implication dans ce forum.

Merci à vous et bonne journée.

AL 22

 

[AtTheOne]

Bonjour @AL 22
Désolé mais je tutoie .. (ancienne culture d'entreprise)

Ce n'est pas dans l'éditeur VBA mais dans XLD, j'insère le code en mode Enrichi et je me tape la mise en forme commentaire par commentaire (du moins lorsque j'en ai le courage).

Amicalement
Alain

 

[AL 22]

Re,

OK, merci à toi pour cette précision.
Personnellement, je trouve que cela accentue le "côté commentaire", mais cela rajoute du travail d'écriture.

À +
AL

 

[AtTheOne]

Bonsoir @erogaki
Pourrais tu dire si la solution proposée au post#2 te conviens et éventuellement le marquer comme solution de ton fil...
Merci d'avance
Amicalement
Alain