XL 2016 optimisation code vba

Y

YANNISE

XLDnaute Junior
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
 

Pièces jointes

  • VBA-CTRL-CLLS.xlsm
    29.6 KB · Affichages: 5
Solution
mapomme
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...
Trier par date Trier par votes
jpb388

jpb388

XLDnaute Accro
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
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
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")
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
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?
 
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
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
 

Pièces jointes

  • YANNISE- VBA-CTRL-CLLS- v1.xlsm
    30.8 KB · Affichages: 3
Vote positif 0 Vote négatif
Solution
Y

YANNISE

XLDnaute Junior
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 :)
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
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à ;)
 
Dernière édition:
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
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à ;)
Cliquez pour agrandir...
🤣🤣🤣🤣🤣
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
Microsoft 365 Erreur sur mon Code VBA
Réponses
2
Affichages
349
Gégé-45550
Gégé-45550
P
  • Résolu(e)
Microsoft 365 Macro qui change l'épaisseur du contour d'une forme
Réponses
11
Affichages
275
pat66
P
p'tit vieux
  • Question
XL 2021 Créer une requête SQL pour lire plusieurs Ranges?
2
Réponses
26
Affichages
991
dysorthographie
dysorthographie
Nicolas JACQUIN
  • Question
XL 2021 Optimisation code pour affichage ligne et colonne
Réponses
14
Affichages
678
patricktoulon
patricktoulon
A
  • Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
137
patricktoulon
patricktoulon
lynyrd
  • Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
528
AtTheOne
AtTheOne
N
  • Résolu(e)
Microsoft 365 Aide pour terminer un code Vba Excel
2
Réponses
23
Affichages
992
job75
job75
T
  • Question
XL 2016 Optimisation d'une boucle
2 3
Réponses
30
Affichages
2 K
thivame
T
S
  • Résolu(e)
Microsoft 365 VBA Match: comment éviter l'erreur?
2
Réponses
29
Affichages
373
Dranreb
Dranreb
R
  • Question
XL 2021 Optimisation Code VBA
Réponses
10
Affichages
616
Dranreb
Dranreb

Membres actuellement en ligne

11 membres et 70 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 096
Messages
2 116 171
Membres
112 676
dernier inscrit
little_b