Correction code VBA

Le 11/08/2022 à 18:13

Bonjour à tous,

Débutant en VBA j'ai tenté de mettre un peu de code sur un de mes fichiers mais malheureusement mes compétences étant très limitées pourriez vous m'apporter votre aide pour apporter des corrections au code ci dessous

Il doit être bourrés d'erreur car ma petite appli me joue des tours en l'occurrence lors des changement de cellules (début du code). Cela fonctionnait a peut prêt jusqu'à hier mais en ajoutant quelques conditions cela a finit par ne plus fonctionner et je galere depuis 2 jours pour tenter de solutionner le problème.

Pour info, une grande partie du code utilisé m'a été fourni par le forum mais j'ai du commettre des erreurs en les mettant bout à bout.

Je pense que cela vient des IF et end if qui ne sont pas placés correctement mais peut être pourrez vous m'en dire un peu plus juste en visualisant le code.

Je vous remercie par avance pour toute l'aide que vous pourrez m'apporter.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim xObjV As Validation

     If Target.Count > 1 Then Exit Sub
      If Not Intersect(Target, Range("B29")) Is Nothing Then
        Range("C33:C52").ClearContents
        Range("B30").Value = "Choisissez une assurance"
     End If
    If Not Intersect(Target, Range("D4")) Is Nothing Then
        Range("D5").ClearContents
        Range("b18").ClearContents
        Range("b20").ClearContents
        End If
     If Not Intersect(Target, Range("B3")) Is Nothing Then
         Range("B4").Select
     End If
      If Not Intersect(Target, Range("B4")) Is Nothing Then
         Range("B5").Select
     End If
      If Not Intersect(Target, Range("B5")) Is Nothing Then
         Range("B6").Select
     End If
      If Not Intersect(Target, Range("B6")) Is Nothing Then
         Range("D3").Select
     End If
      If Not Intersect(Target, Range("D3")) Is Nothing Then
         Range("D4").Select
     End If
      If Not Intersect(Target, Range("D4")) Is Nothing Then
         Range("D5").Select
     End If
     If Not Intersect(Target, Range("D5")) Is Nothing Then
        Range("d6").Select
     End If
     If Not Intersect(Target, Range("D6")) Is Nothing Then
        Range("D7").Select
     End If
     If Not Intersect(Target, Range("D7")) Is Nothing Then
        Range("B9").Select
     End If
     If Not Intersect(Target, Range("B9")) Is Nothing Then
        Range("B11").Select
     End If
     If Not Intersect(Target, Range("b11")) Is Nothing Then
        Range("b29,b30").ClearContents
        Range("c33,c52").ClearContents
        Range("b16").Select
     End If
     If Not Intersect(Target, Range("b16")) Is Nothing Then
        Range("b18").Select
     End If
     If Not Intersect(Target, Range("b18")) Is Nothing Then
        Range("b20,h34").ClearContents
        Range("b20").Select
     End If
      If Not Intersect(Target, Range("b20")) Is Nothing Then
        Range("B22").Select
     End If
     If Not Intersect(Target, Range("b22")) Is Nothing Then
        Range("B24").Select
     End If
     If Not Intersect(Target, Range("b24")) Is Nothing Then
        Range("B26").Select
     End If
     If Not Intersect(Target, Range("b26")) Is Nothing Then
        Range("B29").Select
     End If
     If Not Intersect(Target, Range("b29")) Is Nothing Then
        Range("B30").Select
     End If
    If Not Intersect(Target, Range("B30")) Is Nothing Then
        Range("H34").Value = 0
        Range("H34").Select
    End If
    If Not Intersect(Target, Range("h34")) Is Nothing Then
        Range("c33").Select
    End If

On Error Resume Next
Set xObjV = Target.Validation
If xObjV.Type = xlValidateList Then
 If IsEmpty("b24") Then Target.Value = "NON"
End If

'Mise en majuscule du texte
If Not Application.Intersect(Target, Range("B3:B6,B26")) Is Nothing Then
        If Not IsEmpty(Target) Then
            Application.EnableEvents = False
            Target.Value = UCase(Target.Value)

    End If
    Else
    Application.EnableEvents = True
End If

'Selection des options selon le type de machine
If Not Intersect(Target, Range("C36:C38,C43:C45")) Is Nothing Then
If Range("B29") = "CS100" And Target.Value > "" Then
Target.Value = ""
MsgBox ("Option indisponible pour le type de machine choisie")
End If
End If

If Not Intersect(Target, Range("C33:C35,C37:C38,C43:C45")) Is Nothing Then
If Range("B29") = "CS150" And Target.Value > "" Then
Target.Value = ""
MsgBox ("Option indisponible pour le type de machine choisie")
End If
End If

If Not Intersect(Target, Range("C33:C36,C43:C45")) Is Nothing Then
If Range("B29") = "CS200" And Target.Value > "" Then
Target.Value = ""
MsgBox ("Option indisponible pour le type de machine choisie")
End If
End If

If Not Intersect(Target, Range("C33:C38")) Is Nothing Then
If Range("B29") = "CS400" And Target.Value > "" Then
Target.Value = ""
MsgBox ("Option indisponible pour le type de machine choisie choisi")
End If
End If

If Not Intersect(Target, Range("C33:C38,C43,C45")) Is Nothing Then
If Range("B29") = "CS1000" And Target.Value > "" Then
Target.Value = ""
MsgBox ("Option non disponible pour le type de machine choisie")
End If
End If

Application.EnableEvents = False

If Range("D44") <> "" Then Range("C44").Value = 1: MsgBox ("1 option ? ?t? ajout?")
If Range("D35") <> "" Then Range("C35").Value = 1: MsgBox ("1 option ? ?t? ajout?")
If Range("D37") <> "" Then Range("C37").Value = 1: MsgBox ("1 option ? ?t? ajout?")
If Range("b29").Value = ("CS150") And Range("b11").Value <> 0 Then Range("b11").Value = 0
If Range("b29").Value = ("CSC") Then MsgBox ("OK")
If Range("d34").Value = "FAUX" Then MsgBox "La machine selectionn?e n'est pas adapt?e!": Range("B29").Select
Range("b29").ClearContents
Range("b29").Select

Application.EnableEvents = True
End Sub
Le 11/08/2022 à 23:35

Bonjour,

Sans fichier difficile de t'aider.

Cdt

Le 12/08/2022 à 00:45

Bonsoir rpascal60, fronck,

Sans fichier, impossible de tester, mais il y a pas mal de ménage à faire

Exemple : L'utilisation de Intersect() ne sert à rien s'il n'y a qu'une cellule à tester

Quand je vois les caractères de fin de la sub, il y a passage de Mac à PC 

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim ObjV As Validation
  ' désactiver les évènements
  Application.EnableEvents = False
  ' Attention il faut réactiver les évènements en sortant
  If Target.Count > 1 Then GoTo FinProc
  '
  If Target = Range("B29") Then
    Range("C33:C52").ClearContents
    Range("B30").Value = "Choisissez une assurance"
  End If
  If Target = Range("D4") Then Range("D5,B18,B20").ClearContents
  If Not Intersect(Target, Range("B3:B5")) Is Nothing Then Target.Offset(1, 0).Select
  If Target = Range("B6") Then Range("D3").Select
  If Not Intersect(Target, Range("D3:D6")) Is Nothing Then Target.Offset(1, 0).Select
  If Target = Range("D7") Then Range("B9").Select
  If Target = Range("B9") Then Range("B11").Select
  If Target = Range("B11") Then Range("B29,B30,C33,C52").ClearContents: Range("b16").Select
  If Target = Range("b16") Then Range("b18").Select
  If Target = Range("b18") Then Range("b20,h34").ClearContents: Range("b20").Select
  If Target = Range("b20") Then Range("B22").Select
  If Target = Range("b22") Then Range("B24").Select
  If Target = Range("b24") Then Range("B26").Select
  If Target = Range("b26") Then Range("B29").Select
  If Targte = Range("b29") Then Range("B30").Select
  If Target = Range("B30") Then Range("H34").Value = 0: Range("H34").Select
  If Target = Range("h34") Then Range("c33").Select

  On Error Resume Next
  Set ObjV = Target.Validation
  If ObjV.Type = xlValidateList Then
    If IsEmpty("B24") Then Target.Value = "NON"
  End If

  'Mise en majuscule du texte
  If Not Application.Intersect(Target, Range("B3:B6,B26")) Is Nothing Then
    If Not IsEmpty(Target) Then
      Target.Value = UCase(Target.Value)
    End If
  End If
  'Selection des options selon le type de machine
  If Not Intersect(Target, Range("C36:C38,C43:C45")) Is Nothing Then
    If Range("B29") = "CS100" And Target.Value > "" Then
      Target.Value = ""
      MsgBox ("Option indisponible pour le type de machine choisie")
    End If
  End If

  If Not Intersect(Target, Range("C33:C35,C37:C38,C43:C45")) Is Nothing Then
    If Range("B29") = "CS150" And Target.Value > "" Then
      Target.Value = ""
      MsgBox ("Option indisponible pour le type de machine choisie")
    End If
  End If

  If Not Intersect(Target, Range("C33:C36,C43:C45")) Is Nothing Then
    If Range("B29") = "CS200" And Target.Value > "" Then
      Target.Value = ""
      MsgBox ("Option indisponible pour le type de machine choisie")
    End If
  End If

  If Not Intersect(Target, Range("C33:C38")) Is Nothing Then
    If Range("B29") = "CS400" And Target.Value > "" Then
      Target.Value = ""
      MsgBox ("Option indisponible pour le type de machine choisie choisi")
    End If
  End If

  If Not Intersect(Target, Range("C33:C38,C43,C45")) Is Nothing Then
    If Range("B29") = "CS1000" And Target.Value > "" Then
      Target.Value = ""
      MsgBox ("Option non disponible pour le type de machine choisie")
    End If
  End If
  If Range("D44") <> "" Then Range("C44").Value = 1: MsgBox ("1 option ? ?t? ajout?")
  If Range("D35") <> "" Then Range("C35").Value = 1: MsgBox ("1 option ? ?t? ajout?")
  If Range("D37") <> "" Then Range("C37").Value = 1: MsgBox ("1 option ? ?t? ajout?")
  If Range("b29").Value = ("CS150") And Range("b11").Value <> 0 Then Range("b11").Value = 0
  If Range("b29").Value = ("CSC") Then MsgBox ("OK")
  If Range("d34").Value = "FAUX" Then MsgBox "La machine selectionn?e n'est pas adapt?e!": Range("B29").Select
  Range("b29").ClearContents: Range("b29").Select

FinProc:
  Application.EnableEvents = True
End Sub

A+

Le 12/08/2022 à 09:23

Bonjour BrunoM45,

Tout d'abord je tiens à te remercier d'avoir pris le temps de répondre à ma requête.

Je viens de mettre à jour le code avec tes indications, mais j'ai un petit soucis pour la déclaration de la fonction FinProc que tu as implémenté en fin de code.

Peux tu m'aider stp ?

Le 12/08/2022 à 14:53

Re bonjour BrunoM45, Fronck

Je vous joins un fichier exemple pour mieux comprendre mes besoins. Détails dans le fichier, j'espère ne rien avoir oublié.

J'ai vraiment besoin de votre aide et vous remercie par avance pour le temps que vous voudrez bien consacrer à ma requête.

17validation-des-champs-test.xlsm (39.55 Ko)
Le 12/08/2022 à 22:24

Bonjour bruno, rpascal,

@rpascal

d'abord mieux vaut écrire tes demandes ici dans le post que dans ton fichier.

A chaque entrée dans une cellule, on était ramené à la cellule B29 à cause de l'instruction à la fin de la macro:

 ' Range("B29").ClearContents: Range("B29").Select

Il manquait un end if. (si tu vas à la ligne aprés un If, il faut un end if).

Il y a beaucoup d'approximations:

- Il faut faire attention dans votre écriture à écrire Range("D34") et pas Range("d34"), y'en avait plein comme çà, çà ne s'éxécute pas.

- Il faut se relire: J'ai mis "1 option ajout" à la place de "1 option? t ? ajout?".

J'ai traité tes demandes, mais pour la 3éme:

Ex:3 : Si D4 est supprimer alors on réintialise les B5; B18;B20

Tu as déjà un process sur la zone D3:D7, tu peux pas en avoir 2.

Cdt

10validation-des-champs-test.xlsm (39.32 Ko)
Le 15/08/2022 à 00:50

Bonjour,

Il y avait un bug sur le fichier.

Le revoilà.

Cdt

14validation-des-champs-test.xlsm (39.02 Ko)
Le 15/08/2022 à 10:03

Bonjour Fronck,

J'ai corrigé le code de mon fichier source en tenant compte de tes précieux conseils. Ca semble fonctionner.

Il me reste à présent à gérer l'ordre des tabulations mais pour cela j'ai trouvé un bout de code adapté.

Merci pour ton aide et si besoin je solliciterais à nouveau le forum qui apporte énormément aux novices comme moi.

Bien à toi et bonne journée.

Le 15/08/2022 à 11:53

Bonjour Pascal,

Pour l'ordre des tabulations, il faut faire un clic droit sur le cadre concerné du userform.

image

et monter ou descendre les champs que tu veux.

Cdt

Le 15/08/2022 à 12:05

Bonjour Fronck

Malheureusement je n'utilise pas de Userform. Je suis travail directement avec les cellules du fichier. Mais j'ai trouvé ce code qui fonctionne très bien.

 Dim tabArray As Variant
    Dim i As Long
    tabArray = Array("B3", "B4", "B5", "B6", "D3", "D4", "D5", "D6", "D7", "B9", "B11", "B16", "B22", "B24", "B26", "B29", "B30", "H34", "C33")
      For i = LBound(tabArray) To UBound(tabArray)
        If tabArray(i) = Target.Address(0, 0) Then
            If i = UBound(tabArray) Then
                Me.Range(tabArray(LBound(tabArray))).Select
            Else
                Me.Range(tabArray(i + 1)).Select
            End If
        End If
    Next i

Je te remercie.

Si j'ai d'autre soucis je me permettrai de revenir vers toi si cela ne te dérange pas bien sur ?

Le 15/08/2022 à 23:10

Pas de problème rpascal,

1
Rechercher des sujets similaires à "correction code vba"