Microsoft 365 Simplification de code

[Averell1976]

Bonjour à toutes et à tous,

J'ai développé avec mes maigres connaissances en VBA une cartographie de risques sur EXCEL pour le centre de cancérologie dans lequel je travaille. Le code vba fonctionne et répond à ma demande mais il est très chronophage et je me dis qu'il y a certainement un moyen de faire plus simple, surtout si je dois faire évoluer la cartographie.
Son fonctionnement: la cartographie est formalisée dans l'onglet "CARTOGRAPHIE" et déclinée en 3 grands processus (MANAGEMENT, REALISATION, SUPPORT), puis en type de processus et en sous- processus. Pour chacun d'entre- eux, j'ai crée un bouton de commande; un clic sur chacun d'entre eux permet de visualiser la répartition de la criticité (risque à améliorer/ risque à surveiller/ risque inacceptable). Un double- clic permet de filtrer dans l'onglet "BDD" les risques renseignés et correspondant au bouton sur lequel on a double- cliqué (l'onglet "BDD" permet de renseigner et de stocker l'ensemble des risques identifiés)
Le même code est dupliqué pour chacun des boutons; hyper chronophage. Je suis sûr qu'il y a moyen de faire plus simple (for i= 1 to..... avec i = numéro du bouton par exemple). Ou faire 2 codes dans 2 modules (un pour le click, un pour le double click) et appeler le module correspondant en cliquant ou en double cliquant sur le bouton. Je ne sais pas faire mais je pense que c'est possible. Je vous met le fichier en PJ, plus simple; l'accès au code n'est pas sécurisé.

Un grand merci à vous pour votre aide

 

[vgendron]

Voir PJ
1) la feuille Cartographie et son code n'existe plus !!
2) J'ai "reproduit" la même disposition dans la feuille "Processus"
il suffit d'un double clic pour que:
a) le texte de la cellule cliquée soit mis dans la cellule A2 de la feuille "Recup Données
(à mon avis.. ca ne sert à rien de passer par cette feuille...)
dans la feuille "Processus", j'ai mis les infos "Processus, TypeProcessus et sous processus" dans les cellules C8😀8 et E8
==> si on clique sur un sous processus, les deux autres infos sont recherchées dans la feuille "Liste"
==> si on clique sur un TypeProc==> le sous proc est vidé et on met le processus
==> si on clique sur un Processus ==> les autres sont vidées

b) je pense qu'il faut revoir les formules en F2:F4 ==> que souhaites tu calculer exactement ?


3) pour la feuille "BDD", et le tableau (mis sous forme de Table Structurée t_BDD)
tu as des listes de validation dans les colonnes A B et C
à priori, tu sélectionnes un processus, et donc la liste de validation de la colonne B dépend du choix en A
et ensuite, tu selectionnes B, et donc la liste de C change en fonction de ce que tu as choisi en B

pour ca, j'ai commencé à faire les listes de validations dépendantes
entre A et B, ca marche bien parce qu'il suffit de créer autant de table que de processus
regarde feuille Listes:
colonne F: Un table des processus (3 lignes)
colonne G ==> 3 tables de types processus chacune portant le nom du Processus

mais ensuite.. il faudrait en colonne H autant de tables de sous proc qu'il y a de Type Proc ==> soit 29 tables
j'ai abandonné l'idée de me taper les 29 tables

il me semble qu'il existe un autre moyen plus rapide qui permettrait de filtrer la table des colonnes A B C... avec une formule dans la liste de validation..


4) En ce qui concerne le code que tu avais mis pour les doubles clic, qui permettaient de filtrer la BDD
l'utilisation de Table structurée apporte la possibilité de filtrer rapidement grace aux segments

 

[Rheeem]

Après la suppression tout le code répété il ne reste que ces deux fonctions:

Private Sub PLein_Ecran_Click()
Application.DisplayFullScreen = True
End Sub

Private Sub Quitter_Plein_Ecran_Click()
Application.DisplayFullScreen = False
End Sub

Tout le reste est composé de ces deux codes que l'on peut mettre dans des fonctions ou les gérer autrement ...

Private Sub Informations_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("BDD")
  
    ' Effacer les filtres existants
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
  
    ' Appliquer le filtre pour "INFORMATIONS"
    ws.Range("C6").AutoFilter Field:=3, Criteria1:="INFORMATIONS"
 ws.Activate
End Sub
Private Sub Informations_Click()
Const nSec = 1
Dim fin, old, x
old = Informations.BackColor
Informations.BackColor = &H80FF&
fin = Now() + nSec / 24 / 60 / 60
Informations.BackColor = &HFF&
Label1 = "SOUS- PROCESSUS"
Sheets("RECUP DONNEES").Range("A2").Value = "INFORMATIONS"
Do: DoEvents: Loop While Now() <= fin
Informations.BackColor = old
End Sub

Dans le fichier joint un récapitulatif de toutes les actions des boutons trouvées.

 

[vgendron]

et voila la dernière version pour auj

j'ai remis les boutons "plein écran" et "quitter plein écran"
dans la BDD, les listes de validations sont dépendantes: C de B et B de A

 

[Averell1976]

Re,
Un simple test avec une boucle d'attente faite avec Sleep. ( sans vouloir tout casser )
Mais même avec 1ms d'attente, on voit le bouton changer de couleur à cause de la lenteur de l'outil.
J'ai fait juste une modif à l'arrache mais le principe est d'avoir pour chaque bouton cette structure :

Private Sub Acquisition_Click()
Dim old
old = Acquisition.BackColor
Acquisition.BackColor = &HFF&
Attente
Label1 = "SOUS- PROCESSUS"
Sheets("RECUP DONNEES").Range("A2").Value = "ACQUISITION"
Acquisition.BackColor = old
End Sub

Si c'est trop rapide sur votre PC il faut ajuster la valeur d'attente dans :

Sub Attente()
    Sleep 1 ' 1ms
    DoEvents
End Sub

Principe à tester avec cette PJ.

Re Sylvanu, super l'idée effectivement c'est plus simple. Par contre j'ai l'impression que l'ajustement de la valeur d'attente joue sur le temps nécessaire au bouton pour devenir rouge et non pas sur le temps pendant lequel le bouton est rouge.....

 

[Averell1976]

j'ai regardé de plus près le code
dans la feuille cartographie.. TOUS les boutons n'ont qu'une seule action: mettre un texte en A2 de la feuille Recup données

1) une quantité incroyable de code inutile
2) meme les boutons sont inutiles==> tu peux mettre le texte directement dans les cellules de la feuille et il suffit de cliquer sur UNE cellule pour mettre son contenu dans A2
et ca. ca tient en UNE seule ligne de code
dans l'èvement _selectionchange de la feuille carto
if target<>"" then sheets("Recup").range("A2")=target


tu as aussi codé un _doubleclick sur chaque bouton==> pour mettre en C6 de la feuille BDD.. mais.. C6. c'est une donnée de la première ligne de la table==> tu es sur de toi ??

Bonjour vgendron, merci pour ton aide. Oui , pour C6, je suis sûr de moi; pour le reste tu as raison, mais je préfère rester avec des boutons plutôt qu'avec des cellules (habitude des salariés, pas de problème avec des cellules fusionnées). Mais pour être honnête je n'avais pas pensé à ta solution.... Merci encore à toi d'avoir pris le temps. Je vais continuer à creuser en m'aidant de toutes les solutions proposées ici.

 

[Averell1976]

Après la suppression tout le code répété il ne reste que ces deux fonctions:

Private Sub PLein_Ecran_Click()
Application.DisplayFullScreen = True
End Sub

Private Sub Quitter_Plein_Ecran_Click()
Application.DisplayFullScreen = False
End Sub

Tout le reste est composé de ces deux codes que l'on peut mettre dans des fonctions ou les gérer autrement ...

Private Sub Informations_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("BDD")
 
    ' Effacer les filtres existants
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
 
    ' Appliquer le filtre pour "INFORMATIONS"
    ws.Range("C6").AutoFilter Field:=3, Criteria1:="INFORMATIONS"
 ws.Activate
End Sub
Private Sub Informations_Click()
Const nSec = 1
Dim fin, old, x
old = Informations.BackColor
Informations.BackColor = &H80FF&
fin = Now() + nSec / 24 / 60 / 60
Informations.BackColor = &HFF&
Label1 = "SOUS- PROCESSUS"
Sheets("RECUP DONNEES").Range("A2").Value = "INFORMATIONS"
Do: DoEvents: Loop While Now() <= fin
Informations.BackColor = old
End Sub

Dans le fichier joint un récapitulatif de toutes les actions des boutons trouvées.

Bonjour Rheem, merci pour ta solution; mais le Private sub Informations_Click() et le Private sub Informations_DblClcik()..... ça ne marche que pour le bouton "Informations".... je dois dupliquer ces 2 codes à tous les autres boutons non?

 

[Averell1976]

et voila la dernière version pour auj

j'ai remis les boutons "plein écran" et "quitter plein écran"
dans la BDD, les listes de validations sont dépendantes: C de B et B de A

Merci à toi pour le temps consacré; effectivement le code est pour le coup ultra simplifié. Cependant, après sondage auprès des futurs utilisateurs, je vais rester sur les clics de boutons plutôt que sur les clics de cellules. C'est plus "clair" pour eux. Je vais donc creuser la piste bouton de formulaire plutôt que bouton ActivX.

 

[Averell1976]

Hello, merci pour ton aider. Comment récupérer le nom du bouton qui fait appel à la macro?

Bonsoir Vgendron,
C'est pour ça que j'ai précisé : ( sans vouloir tout casser ) 🙂
L'autre solution bien meilleure est d'utiliser des Shapes à la place des CommandButton.
Et le tout se gère en 5 lignes avec Application.caller, mais ça fait casser tout.

Solution adaptée à ce que je recherche; pas grave si je dois tout casser; maic comment coder un code unique qui s'applique à toutes les Shapes? Comment utiliser application.caller?

 

[vgendron]

Hello

C'est plus "clair" pour eux.

?? cliquer sur un bouton plutot que sur une cellule??
je vois vraiment pas la différence...
si c'est juste le coté "Joli" des boutons, tu peux reproduire les memes effets visuels avec les cellules..

 

[vgendron]

du coup.. pour aller au bout de ma proposition, en PJ
double clic dans la feuille Processus
==> les valeurs sont mises à jour
==> la BDD est filtrée
et la feuille BDD est affichée

 

[Rheeem]

mais le Private sub Informations_Click() et le Private sub Informations_DblClcik()..... ça ne marche que pour le bouton "Informations".... je dois dupliquer ces 2 codes à tous les autres boutons non?

Ces deux fonctions étaient cité juste à titre d'exemple , l'idée est de placer leurs codes dans dans une procédure paramétrée pour le rendre plus facile à exploiter par le reste des boutons .

Dans l'échantillonnant suivant tous les boutons sont virés et remplacés par zones de texte sans changer l'effet visuel que tu as développé pour les boutons , , le fait de retirer ces boutons ActiveX a bien alléger le fichier et le démarrage est plus fluide.

 

[Averell1976]

Ces deux fonctions étaient cité juste à titre d'exemple , l'idée est de placer leurs codes dans dans une procédure paramétrée pour le rendre plus facile à exploiter par le reste des boutons .

Dans l'échantillonnant suivant tous les boutons sont virés et remplacés par zones de texte sans changer l'effet visuel que tu as développé pour les boutons , , le fait de retirer ces boutons ActiveX a bien alléger le fichier et le démarrage est plus fluide.

Ah ça c'est top!!!! Merci Rheeem; je tiens juste à séparer les actions par click et par double click.... mais je pense que je vais pouvoir gérer ça.... Merci à toi

 

[oguruma]

Bonsoir Vgendron,
C'est pour ça que j'ai précisé : ( sans vouloir tout casser ) 🙂
L'autre solution bien meilleure est d'utiliser des Shapes à la place des CommandButton.
Et le tout se gère en 5 lignes avec Application.caller, mais ça fait casser tout.

Bonjour pour rebondir sur ce que suggère sylvanu à juste titre voir mon outil
qui a pour module de pilotage
il se trouve ICI

ensuite si tu souhaites afficher des messages d'attente via une barre de progression, avec Patrick TOULON (son code d'origine) on a remis sur scène cette barre de progression sur laquelle j'ai apporté quelques modifications ICI

Quand je lis ton code... si tu m'accordes ce constat.... ça sent l'enregistreur de Macro...
C'est une bonne pratique certes qui donne de bonnes pistes mais après il faut optimiser car il t'en beaucoup trop.

Pour conclure je recommande les Shape.... et je crois que Sylvanu a fait un excellent tuto sur ces composants... (dsl Sylvanu si je me trompe 🙂)


Je recommande ce type de développement avec le Caller qui est plus central et plus maintenable. C'est un peu compliqué mais il faut en voir les avantages de la maintenance.

Sub MAIN()
STACK = "MAIN()"

    Dim vAppel As Variant
    Dim sType As String
    Dim sTitre As String
    Dim sTypeFiltre As String
    Dim sFiltre As String
    Dim sMessage As String
    Dim oShapeSource As Shape
    Dim oShapeCible As Shape
    Dim sShapeSource As String
    Dim sShapeCible As String
    
    
    On Error GoTo HANDLE_ERROR

    Set oSpeed = New SpeedMacro
    oSpeed.SpeedMacroOn
    
    Set oShapeSource = ActiveSheet.Shapes("ZONE_TEXTE_SOURCE")
    Set oShapeCible = ActiveSheet.Shapes("ZONE_TEXTE_CIBLE")
    
    sShapeSource = oShapeSource.TextFrame2.TextRange.Characters.Text
    sShapeCible = oShapeCible.TextFrame2.TextRange.Characters.Text
        
    '*=*=*=*=*=*=*=*=*=*=*=*=*==*=*=*=*=*=*=*=*=*=*=*
    ' Classeur exécutant les macros de l'outil
    '*=*=*=*=*=*=*=*=*=*=*=*=*==*=*=*=*=*=*=*=*=*=*=*
    Set gWB_MACRO = ThisWorkbook
        
    '*=*=*=*=*=*=*=*=*=*=*=*=*==*=*=*=*=*=*=*=*=*=*=*
    ' Chargement de la table des paramètres
    '*=*=*=*=*=*=*=*=*=*=*=*=*==*=*=*=*=*=*=*=*=*=*=*
    Set oParameters = New Cls_CollectionParameters
    Call oParameters.Instanciate
    
    '*=*=*=*=*=*=*=*=*=*=*=*=*==*=*=*=*=*=*=*=*=*=*=*
    ' Chargement de la table des messages
    '*=*=*=*=*=*=*=*=*=*=*=*=*==*=*=*=*=*=*=*=*=*=*=*
    Set oMsg = New Cls_MessagesDialog
    Call oMsg.Intanciate
    
    Set gWK_MACRO = Sheets(WK_ACCUEIL)

    sType = TypeName(Application.Caller)
    Select Case sType
        Case "Range"
            vAppel = Application.Caller.Address
        Case "String"
            vAppel = Application.Caller
        Case "Error"
            vAppel = "Error"
        Case Else
            vAppel = "unknown"
    End Select
    
    If sType <> "String" Then
        MsgBox oMsg.GetMessage("M_MSG001"), vbExclamation, APPLI
        Error.Raise ERROR_PQW, ERROR_PQW_SOURCE, ERROR_PQW_MSG
        Exit Sub
    End If
    
    '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
    ' Bouton de la source
    '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
    Select Case vAppel
        Case "FOLDER_SOURCE"
            Call GET_FILE_NAME_XL(SOURCE)
            
        Case "FOLDER_CIBLE"
            Call GET_FILE_NAME_XL(CIBLE)
            
        Case "BTN_INVENTORIER_SOURCE", "SH_INVENTORIER_SOURCE"
            Call INVENTORIER(SOURCE, DIALOG)
            
        Case "BTN_INVENTORIER_CIBLE", "SH_INVENTORIER_CIBLE"
            Call INVENTORIER(CIBLE, DIALOG)
        
        Case "BTN_COPY_OFF"
            Call SET_OPTION_COLUMN("COPIE", SOURCE, SET_NON, DIALOG)
            
        Case "BTN_COPY_ON"
            Call SET_OPTION_COLUMN("COPIE", SOURCE, SET_OUI, DIALOG)
            
        Case "BTN_DATA_OFF"
            Call SET_OPTION_COLUMN("DATA", SOURCE, SET_NON, DIALOG)
            
        Case "BTN_DATA_ON"
            Call SET_OPTION_COLUMN("DATA", SOURCE, SET_OUI, DIALOG)
            
        Case "BTN_FORCE_OFF"
            Call SET_OPTION_COLUMN("FORCE", SOURCE, SET_NON, DIALOG)
            
        Case "BTN_FORCE_ON"
            Call SET_OPTION_COLUMN("FORCE", SOURCE, SET_OUI, DIALOG)
            
        Case "BTN_IMPORTER_CIBLE", "SH_IMPORTER_CIBLE"
            Call IMPORTER_QUERIES(DIALOG)
            
        Case "SH_IMPORTER_RQ_TXT"
            IMPORTER_QUERY_TXT (DIALOG)
            
        Case "SH_EXPORT_TEXTE"
            Call VOIR_REQUETE("TXT", DIALOG)
            
        Case "BTN_VOIR"
            Call VOIR_REQUETE("FRM", DIALOG)
        
        Case "SH_POUBELLE"
            Call SUPPRIMER_QUERY(DIALOG)
            
        Case "SH_BANNIERE"
            MsgBox "Version " & VERSION, vbInformation, APPLI
            
        Case "SH_ACTUALISER"
            Call INVENTORIER(CIBLE, NO_DIALOG)
            
        Case Else
            MsgBox oMsg.GetMessage("M_MSG001"), vbExclamation, APPLI
    End Select
    
    
FIN:
    oSpeed.SpeedMacroOff
    Set oSpeed = Nothing
    Exit Sub

HANDLE_ERROR:
    oSpeed.SpeedMacroOff
    
    '*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
    ' Gestion des erreurs - Stack manuel sur l'appel des fonctions
    '*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
    MsgBox STACK & vbLf & _
        ERR_ATTENTION_1 & vbLf & _
        ERR_ATTENTION_2 & Err.Number & vbLf & _
        Err.SOURCE & vbLf & _
        Err.Description, vbCritical, APPLI
        
    Resume FIN
End Sub

 

[oguruma]

tu te rends compte que tu écris TOUT ce code

Private Sub Management_Click()

Const nSec = 1
Dim fin, old, x
old = Management.BackColor
Management.BackColor = &H8000&
fin = Now() + nSec / 24 / 60 / 60

Management.BackColor = &HFF&
Label1 = "PROCESSUS"
Sheets("RECUP DONNEES").Range("A2").Value = "MANAGEMENT"
Do: DoEvents: Loop While Now() <= fin
Management.BackColor = old

End Sub

JUSTE pour mettre un mot "MANAGEMENT" dans la cellule A2 de la feuille "Recup données"

Re...
je comprends parfaitement la stupéfaction de vgendron 🙂
Pour affecter une celllule comme tu le fais
Sheets("RECUP DONNEES").Range("A2").Value = "MANAGEMENT"
Dans ton onglet "RECUP DONNEES" tu vas nommer la cellule A2 en lui affectant par exemple le nom TAG_MANAGEMENT
et dans ton code il suffit de remplacer cette ligne Sheets("RECUP DONNEES").Range("A2").Value = "MANAGEMENT" par RANGE("TAG_MANAGEMENT")="MANAGEMENT" ou encore pour être plus précis dans le code RANGE("TAG_MANAGEMENT").Value="MANAGEMENT"
.Value étant la propriété par défaut quand elle n'est pas mentionnée

Autre point
Dim fin, old, x ==> sans précision ces variables seront de type variant donc très lourdes en mémoire
je t'invite à typer spécifiquement tes variables
exemple
dim x as integer
dim fin as long
dim machaine as string
voir pour être plus clair dans le code
dim iDx as integer =>> préfixe "i" pour integer
dim lngFin as long =>> préfixe lng pour long
dim sChaine as string =>> préfixe s pour string
dim sLabel1 as string

Cela te permettra de mieux t'y retrouver dans ton code pour la maintenance...
ou te rapprocher de ce que l'on appelle la notation hongroise comme on le fait en langage C

Const nSec = 1 serait mieux Const NSEC = 1 ( les constantes toutes en majuscules)

Certes ça ne solutionne pas ton problème mais ça peut te donner des pistes pour tes autres développements surtout si tu as une boucle avec un compteur inférieur à 326767 passage déclare ta variable de boucle par un Integer

 

[Rheeem]

je tiens juste à séparer les actions par click et par double click.... mais je pense que je vais pouvoir gérer ça....

Le double click n'est pas géré nativement par les zonzq de text les qhshape et les contoles de formulaires seule les controles ActiveX les gèrent ,il faut trouver une astuce pour créer un pseudo Dbl click en calculant l'écart entre deux clicks successifs et les convertir à l evenement Dbl clicks..

Private Function ClickDetect() As String
 Static LastHit As Single
 Static Listening As Boolean
 Dim w As Single
 If Not Listening Then
    Listening = True
    w = Timer
    While Timer - w < 0.6
      DoEvents
    Wend
    Listening = False
    If Timer - LastHit > 0.6 Then
      ClickDetect = "Clk"
    Else
      ClickDetect = "Dbl"
    End If
 End If
 LastHit = Timer
End Function

Sub GlobalClick()
Dim mAction As String
mAction = ClickDetect
 
If mAction = "" Then Exit Sub ' un clique mort 

Dim Indice As Long, Btn As Object
Dim Cfg, nName As String
Set Cfg = Range("BtnConfig")
nName = Application.Caller
For I = 1 To Cfg.Rows.Count
    If Cfg(I, 1) = nName Then
       Indice = I
       Exit For
     End If
Next

If Indice = 0 Then
  MsgBox "Nom introuvable " & nName
  Exit Sub
End If

Set Btn = Worksheets("CARTOGRAPHIE").Shapes(nName)
If mAction = "Clk" Then
    'effet visuel
    Const nSec = 1#
    Dim fin, old, x
    old = Btn.Fill.ForeColor.RGB
    Btn.Fill.ForeColor.RGB = Cfg(Indice, 2).Interior.Color
    fin = Now() + nSec / (24# * 60# * 60#)
    Btn.Fill.ForeColor.RGB = &HFF&
    Worksheets("CARTOGRAPHIE").Label1 = Cfg(Indice, 3)
    Sheets("RECUP DONNEES").Range("A2").Value = Cfg(Indice, 4)
    Do: DoEvents: Loop While Now() <= fin
    Btn.Fill.ForeColor.RGB = old
Else ' Dbl doubleClick
    'filtrage ...
    If Cfg(Indice, 6) = "" Then Exit Sub
   
    Dim ws As Worksheet, rng
    Set ws = ThisWorkbook.Sheets("BDD")
     
    If ws.AutoFilterMode Then
       ws.AutoFilterMode = False
    End If
    ' Appliquer le filtre pour ""
    Set rng = ws.Range(Cfg(Indice, 5))
     rng.AutoFilter Field:=rng.Column, Criteria1:=Cfg(Indice, 6)
     ws.Activate
End If

End Sub

J'ai fixé l'écart à 0.6 s car j'utilse un laptop et sans souris et un double click est plus long à détecter tu peux l'ajuster selon le besoin .