XL 2016 optimisation code vba

YANNISE · 18 Mars 2022

Bonjour le Forum,

Pourrez-vous m’aider à optimiser mon code ci-dessous s’il vous plait

Notamment le fichier exemple ci-joint, merci d’avance

VB:

Sub ctrl()
Dim repense As Integer

If Feuil1.Range("B4") = "" Then
    Feuil1.Range("B4").Interior.ColorIndex = 3
       repense = MsgBox("Champ de saisie 'A' non renseigné", vbCritical + vbOKOnly, "Champ non renseigné")
        Exit Sub
    ElseIf Feuil1.Range("B4") >= 0 Then
    Feuil1.Range("B4").Interior.Color = xlColorIndexNone
End If

If Feuil1.Range("D5") = "" Then
    Feuil1.Range("D5").Interior.ColorIndex = 3
        repense = MsgBox("Champ de saisie 'B' non renseigné", vbCritical + vbOKOnly, "Champ non renseigné")
        Exit Sub
    ElseIf Feuil1.Range("B4") >= 0 Then
    Feuil1.Range("D5").Interior.Color = xlColorIndexNone
End If

If Feuil1.Range("B7") = "" Then
    Feuil1.Range("B7").Interior.ColorIndex = 3
        repense = MsgBox("Champ de saisie 'C' non renseigné", vbCritical + vbOKOnly, "Champ non renseigné")
        Exit Sub
    ElseIf Feuil1.Range("B7") >= 0 Then
    Feuil1.Range("B7").Interior.Color = xlColorIndexNone
End If

If Feuil1.Range("E7") = "" Then
    Feuil1.Range("E7").Interior.ColorIndex = 3
        repense = MsgBox("Champ de saisie 'D' non renseigné", vbCritical + vbOKOnly, "Champ non renseigné")
        Exit Sub
    ElseIf Feuil1.Range("E7") >= 0 Then
    Feuil1.Range("E7").Interior.Color = xlColorIndexNone
End If

If Feuil1.Range("B15") = "" Then
    Feuil1.Range("B15").Interior.ColorIndex = 3
        repense = MsgBox("Champ de saisie 'E' non renseigné", vbCritical + vbOKOnly, "Champ non renseigné")
        Exit Sub
    ElseIf Feuil1.Range("B15") >= 0 Then
    Feuil1.Range("B15").Interior.Color = xlColorIndexNone
End If

If Feuil1.Range("E15") = "" Then
    Feuil1.Range("E15").Interior.ColorIndex = 3
        repense = MsgBox("Champ de saisie 'F' non renseigné", vbCritical + vbOKOnly, "Champ non renseigné")
        Exit Sub
    ElseIf Feuil1.Range("E15") >= 0 Then
    Feuil1.Range("E15").Interior.Color = xlColorIndexNone
End If

Feuil2.Range("B9999").End(xlUp).Offset(1, 0) = Feuil1.Range("B4")
Feuil2.Range("C9999").End(xlUp).Offset(1, 0) = Feuil1.Range("D5")
Feuil2.Range("D9999").End(xlUp).Offset(1, 0) = Feuil1.Range("B7")
Feuil2.Range("E9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E7")
Feuil2.Range("F9999").End(xlUp).Offset(1, 0) = Feuil1.Range("B15")
Feuil2.Range("G9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E15")

Call clear_dn

End Sub

Sub clear_dn()

Dim réponse As Integer
réponse = MsgBox(vbCr & "    " & "Les données ont bien été enregistrées" & vbCr & " " & vbCr & " " & "Voulez-vous effacer les champs de saisie ?" _
            , vbInformation + vbYesNo, "Enregistrement effectué...")

If réponse = 6 Then
 Feuil1.Range("B4").ClearContents
 Feuil1.Range("D5").MergeArea.ClearContents
 Feuil1.Range("B7").MergeArea.ClearContents
 Feuil1.Range("E7").MergeArea.ClearContents
 Feuil1.Range("B15").MergeArea.ClearContents
 Feuil1.Range("E15").MergeArea.ClearContents
ElseIf réponse = 7 Then
',B7,E7,B15,E15
End If

End Sub

mapomme · 19 Mars 2022

Bonsoir à tous ,

Une autre manière...

Les adresses des champs sont paramétrés dans une constante Adresse en début de module. On peut donc ajouter ou retirer facilement des champs sans modifier le codes des deux procédures.
On vérifie tous les champs en une seule passe, on colorie tous les champs non renseignés, on informe l'utilisateur des noms de tous les champs non renseignés (noms recherchés directement sur Feuil1), et on sélectionne le premier champ à compléter.
le code est un peu commenté.

VB:

Option Explicit
Const Adresse = "b4,d5,b7,e7,b15,e15"     'les adresses des champs

Sub Verif()
Dim Adresses, Noms, i&, n&, ErreurAdresses, ErreurNoms
   Adresses = Split(Adresse, ",")   'on éclate la...

jpb388 · 18 Mars 2022

Bonjour à tous
en supposant que tous les champs doivent être renseignés

VB:

Sub ctrl()
      Dim Reponse As Byte
      Dim PL As Range, Cel As Range, Lettre$, Message$
      
      Set PL = Feuil1.Range("B4,D5,B7,E7,B15,E15")
      For Each Cel In PL
            Select Case Cel.Address(False, False, xlA1)
                  Case "B4": Lettre = "'A'"
                  Case "D5": Lettre = "'B'"
                  Case "B7": Lettre = "'C'"
                  Case "E7": Lettre = "'D"
                  Case "B15": Lettre = "'E'"
                  Case "E15": Lettre = "'F'"
            End Select
            Select Case Cel.Text
                  Case Is = ""
                        Cel.Interior.ColorIndex = 3
                        If Message = "" Then Message = "Champ de saisie " & Lettre Else Message = Message & ", " & Lettre
                  Case Else: Cel.Interior.ColorIndex = xlColorIndexNone
            End Select
      Next Cel
      If Message <> "" Then
            MsgBox Message & " non renseigné", vbCritical + vbOKOnly, "Champ non renseigné"
      Else
            Feuil2.Range("B9999").End(xlUp).Offset(1, 0) = Feuil1.Range("B4")
            Feuil2.Range("C9999").End(xlUp).Offset(1, 0) = Feuil1.Range("D5")
            Feuil2.Range("D9999").End(xlUp).Offset(1, 0) = Feuil1.Range("B7")
            Feuil2.Range("E9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E7")
            Feuil2.Range("F9999").End(xlUp).Offset(1, 0) = Feuil1.Range("B15")
            Feuil2.Range("G9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E15")
            Reponse = MsgBox(vbCr & "    " & "Les données ont bien été enregistrées" & vbCr & " " & vbCr & " " & "Voulez-vous effacer les champs de saisie ?" _
                        , vbInformation + vbYesNo, "Enregistrement effectué...")
            If Reponse = 6 Then clear_dn
      End If
End Sub

Sub clear_dn()
      With Feuil1.Range("B4,D5:E5,B7:C7,E7:F7,B15:C16,E15:F15")
            .Interior.Pattern = xlNone
            .ClearContents
      End With
End Sub

Staple1600 · 18 Mars 2022

Bonjour

Un petit bout de simplification
(pas forcément une "optimisation")
Ceci

Code:

Sub essai()
Dim vArr
With Feuil1: vArr = Array(.[B4], .[D5], .[B7], .[E7], .[B15], .[E16]): End With
Feuil2.Cells(Rows.Count, "B").End(3).Offset(1).Resize(, 6).Value = vArr
End Sub

équivaut (enfin j'espère ) à :

VB:

Feuil2.Range("B9999").End(xlUp).Offset(1, 0) = Feuil1.Range("B4")
            Feuil2.Range("C9999").End(xlUp).Offset(1, 0) = Feuil1.Range("D5")
            Feuil2.Range("D9999").End(xlUp).Offset(1, 0) = Feuil1.Range("B7")
            Feuil2.Range("E9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E7")
            Feuil2.Range("F9999").End(xlUp).Offset(1, 0) = Feuil1.Range("B15")
            Feuil2.Range("G9999").End(xlUp).Offset(1, 0) = Feuil1.Range("E15")

Staple1600 · 18 Mars 2022

Re

Dans la continuation de ma 1ère proposition

VB:

Sub essai_2()
Dim rng As Range, vArr
Set rng = Feuil1.Range("B4,D5,B7,E7,B15,E15")
check = Application.CountA(rng)
rng.Interior.ColorIndex = Switch(check = 6, -4142, check = 0, 3)
If check = 0 Then
MsgBox "Saisie incomplète!", vbCritical
Else
With Feuil1: vArr = Array(.[B4], .[D5], .[B7], .[E7], .[B15], .[E16]): End With
Feuil2.Cells(Rows.Count, "B").End(3).Offset(1).Resize(, 6).Value = vArr
End If
End Sub

Est-ce que je me rapproche du résultat original?

mapomme · 19 Mars 2022

Bonsoir à tous ,

Une autre manière...

Les adresses des champs sont paramétrés dans une constante Adresse en début de module. On peut donc ajouter ou retirer facilement des champs sans modifier le codes des deux procédures.
On vérifie tous les champs en une seule passe, on colorie tous les champs non renseignés, on informe l'utilisateur des noms de tous les champs non renseignés (noms recherchés directement sur Feuil1), et on sélectionne le premier champ à compléter.
le code est un peu commenté.

VB:

Option Explicit
Const Adresse = "b4,d5,b7,e7,b15,e15"     'les adresses des champs

Sub Verif()
Dim Adresses, Noms, i&, n&, ErreurAdresses, ErreurNoms
   Adresses = Split(Adresse, ",")   'on éclate la constante Adresse en un tableau (array) Adresses (de base 0)
   Feuil1.Range(Adresse).Interior.ColorIndex = xlColorIndexNone   'fond des champs incolore
   For i = 0 To UBound(Adresses)    'pour chaque adresse des champs
      If Feuil1.Range(Adresses(i)) = "" Then
         'si la cellule avec cette adresse est vide,on concatène l'adresse de la cellule à la chaine ErreurAdresses
         'avec le séparateur ", "
         ErreurAdresses = ErreurAdresses & ", " & Adresses(i)
         'on concatène le nom du champ à la la chaine ErreurNoms avec le séparateur ", "
         'le nom du champ est dans la cellule juste au-dessus de la cellule du champ vide
         ErreurNoms = ErreurNoms & ", " & Feuil1.Range(Adresses(i)).Offset(-1)
      End If
   Next i
   'on ôte l'éventuel séparateur parasite en tête des deux chaines de caractères
   ErreurAdresses = Mid(ErreurAdresses, 3): ErreurNoms = Mid(ErreurNoms, 3)
   'à ce stade si ErreurAdresses est vide, c'est que la saisie est correcte
   If ErreurAdresses <> "" Then
      'ErreurAdresses n'est pas vide => il y a un ou des champs non saisis
      'on colore les champs non renseignés en rose
      Feuil1.Range(ErreurAdresses).Interior.Color = RGB(255, 155, 255)
      'on informe l'utilisateur des noms de champs non renseignés
      MsgBox "Champ(s) non renseigné(s) :  " & vbLf & vbLf & ErreurNoms, vbCritical, "Erreur saisie"
      Feuil1.Range(Left(ErreurAdresses & ",", InStr(ErreurAdresses & ",", ",") - 1)).Select
      Exit Sub
   End If
   'si on est parvenu jusqu'ici, c'est que tous les champs sont remplis
   'n => numéro de la ligne à remplir sur Feuil2
   n = Feuil2.Cells(Rows.Count, "d").End(xlUp).Row + 1
   'boucle sur les adresses des champs pour remplir la ligne n de Feuil2 (à partir de la colonne B)
   For i = 0 To UBound(Adresses): Feuil2.Cells(n, "B").Offset(, i) = Feuil1.Range(Adresses(i)): Next
   Effacer
End Sub

Sub Effacer()
Dim réponse As Integer
   réponse = MsgBox(vbCr & "    " & "Les données ont bien été enregistrées." & vbCr & " " & vbCr & " " & _
      "Voulez-vous effacer les champs de saisie ?", vbQuestion + vbYesNo + vbDefaultButton2, "")
   If réponse = 6 Then Feuil1.Range(Adresse) = ""
   Feuil1.Range(Adresse).Interior.ColorIndex = xlColorIndexNone
End Sub

YANNISE · 19 Mars 2022

Bonjour à tous;
Je vous remercie tous de bien vouloir apporter vos savoirs à ma demande
je retiens vos réponses même certaines ne sont pas complètes
JPB388 et MAPOMME vos réponses me convient parfaitement
Merci encore une fois

Staple1600 · 19 Mars 2022

Bonjour

YANNISE
Moi, j'avais prévenu d'emblée d'abord avec mon petit bout
et ensuite avec le nom de mes macros : essai*

(Mais tu n'as pas répondu à ma question. Tu as testé mon code ?
Celui du message#4)

NB: C'est volontaire de ma part, de ne pas proposer d'emblée une solution 100% fonctionnelle.
Le fol espoir qui m'anime ce faisant, c'est que le-a demandeur-resse mette les mains dans le cambouis et mouille le maillot pour résoudre sa question
Pour pouvoir se dire, le matin en se rasant: "Cette tite macro c'est moi qui l'ai faite et O bonheur j'ai compris sa syntaxe grâce à mes tests et aux conseils des membres du forum.

NB: On notera que j'ai été contaminé par l'écriture inclusive mais que j'ai une mauvaise connaissance de la gestion par la gent féminine de son système pileux.
Car j'ignore totalement si elle se rase le matin en pensant VBA
Ou si elle s'épile à la cire en fin d'après-midi autour d'une infusion à l'hibiscus tout en repensant à Excel et son VBA.
=> Spéciale dédicace à @Marcel32
Niveau digression, j'ai bien digressé là

mapomme · 19 Mars 2022

Staple1600 à dit:
Pour pouvoir se dire, le matin en se rasant: "Cette tite macro c'est moi qui l'ai faite et O bonheur j'ai compris sa syntaxe grâce à mes tests et aux conseils des membres du forum.

NB: On notera que j'ai été contaminé par l'écriture inclusive mais que j'ai une mauvaise connaissance de la gestion par la gent féminine de son système pileux.
Car j'ignore totalement si elle se rase le matin en pensant VBA
Ou si elle s'épile à la cire en fin d'après-midi autour d'une infusion à l'hibiscus tout en repensant à Excel et son VBA.
=> Spéciale dédicace à @Marcel32
Niveau digression, j'ai bien digressé là

XL 2016 optimisation code vba

YANNISE

XLDnaute Junior

Pièces jointes

mapomme

jpb388

XLDnaute Accro

Staple1600

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Pièces jointes

YANNISE

XLDnaute Junior

Staple1600

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Discussions similaires