Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2021 Erreur d'exécution 424

Usine à gaz

XLDnaute Barbatruc
Bjr à toutes et à tous

Je n'arrive pas à coder comme il faut et j'ai :

J'ai besoin que le code s'exécute si clic ligne active cellules de J à S
Auriez-vous le bon code ?
Un grand merci à toutes et à tous
 
Trier par date Trier par votes

Usine à gaz

XLDnaute Barbatruc
Bon, je vais tenter de voir mais je ne sais pas faire ça.
 
Vote positif 0 Vote négatif

Usine à gaz

XLDnaute Barbatruc
ok les voici :
Private Sub Worksheet_SelectionChange(ByVal R As Range)
VB: 
Private Sub Worksheet_SelectionChange(ByVal R As Range)
    'If Not Intersect(R, Range("e6:s30000")) Is Nothing And R.Count = 1 Then
    If Not Intersect(R, Range("e6:s30000")) Is Nothing And R.CountLarge = 1 Then
        Application.EnableEvents = False
        [x2] = 0
        [x2].FormulaR1C1 = "=RIGHT(R[-1]C[-14],1)"
        Calculate
        If [x2] <> "K" Then
            ActiveSheet.Cells(Rows.Count, "e").End(xlUp)(1).Select
        'Rows("7:30000").RowHeight = 0
            Else
            [x2] = 0
            'Rows("7:30000").RowHeight = 50
        End If
        Application.EnableEvents = True
    End If

    If Not Intersect(R, Range("g6:h30000")) Is Nothing And R.Count = 1 Then
    If R <> "" Then
        If MsgBox("      Vous appelez ?" & Chr(10) & Chr(10) & "OUI         ou        NON", vbQuestion + vbYesNo) <> vbYes Then
        Cells(ActiveCell.Row, 5).Activate
        Application.CutCopyMode = False
        Exit Sub
        End If
        ActiveCell.Name = "MaCell" 'nomme la cellule
        Cells(ActiveCell.Row, 5).FormulaR1C1 = "=TODAY()"
        Cells(ActiveCell.Row, 5).Value = Cells(ActiveCell.Row, 5).Value
        Cells(ActiveCell.Row, 12).ClearContents
        R.Copy
        Cells(ActiveCell.Row, 5).Activate
        Exit Sub
        End If
    End If

    If Not Intersect(R, Range("l6:l30000")) Is Nothing And R.Count = 1 Then
        If Cells(ActiveCell.Row, 7) = "" Then
            Application.EnableEvents = False
            Cells(ActiveCell.Row, 5).Select
                MsgBox ("Manque N° Tel")
            Application.EnableEvents = True
            Exit Sub
        End If
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    affectations.Show

If Cells(ActiveCell.Row, 12) = "Répondeur" Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Cells(ActiveCell.Row, 13) = ""
    Cells(ActiveCell.Row, 13).FormulaR1C1 = "=TODAY()+5"
    Cells(ActiveCell.Row, 13).Value = Cells(ActiveCell.Row, 13).Value
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    End If

    If Cells(ActiveCell.Row, 12) = "A Rappeler" Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Cells(ActiveCell.Row, 13) = ""
    Cells(ActiveCell.Row, 14) = ""
    Cells(ActiveCell.Row, 15) = ""
    fm_CalendrierCellMinMax.Show

    If Cells(ActiveCell.Row, 13) = "" Then
    MsgBox ("Il faut sélectionner une date de rappel avant de quitter le calendrier")
    fm_CalendrierCellMinMax.Show
    End If

    Cells(ActiveCell.Row, 20).FormulaR1C1 = "=IF(OR(R[-2]C[-13]="""",RC[-10]=""""),0,IF(AND(RC[-7]>0,RC[-7]<TODAY()+1),""R"",0))"
    Cells(ActiveCell.Row, 21).FormulaR1C1 = "=IF(RC[-1]=""R"",""Appelez vite"","""")"
    Cells(ActiveCell.Row, 20).Value = Cells(ActiveCell.Row, 20).Value
    Cells(ActiveCell.Row, 21).Value = Cells(ActiveCell.Row, 21).Value
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    End If

    If Cells(ActiveCell.Row, 12) <> "" Then 'si L vide
        tableau_client = ThisWorkbook.Sheets("ClientsCoordonnées").Range("Clients").Value
        ActiveSheet.Cells(ActiveCell.Row, 16).Value = rechercher_tab(tableau_client, Cells(ActiveCell.Row, 10), 3, 1) & " " & rechercher_tab(tableau_client, ActiveSheet.Cells(ActiveCell.Row, 10), 4, 1)
    Cells(ActiveCell.Row, 5).Select
    End If
    End If

    Application.EnableEvents = True
    Application.ScreenUpdating = True

    If Not Intersect(R, Range("m6:m30000")) Is Nothing And R.Count = 1 Then
     MsgBox ("Pour mettre ou changer la date de rappel, il faut réaffecter")
     Cells(ActiveCell.Row, 1).Select
     Exit Sub
     End If

    If Not Intersect(R, Range("r6:r30000")) Is Nothing And R.Count = 1 Then
    If [x2] > 0 Then: Exit Sub
        R.Activate
        If R <> "" Then
            If MsgBox("Lien déjà présent : modifier ?" & Chr(10) & Chr(10) & "     OUI         ou        NON", vbQuestion + vbYesNo) <> vbYes Then
            Exit Sub
            End If
        End If
        lien
    End If

    If Not Intersect(R, Range("s6:s30000")) Is Nothing And R.Count = 1 Then
    If [x2] > 0 Then: Exit Sub
        If R <> "" Then
            If MsgBox("Annonce déjà présente : modifier ?" & Chr(10) & Chr(10) & "                 OUI         ou        NON", vbQuestion + vbYesNo) <> vbYes Then
            Exit Sub
            End If
        End If
        annonce
    End If

End Sub
Target
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("J6:J30000")) Is Nothing Then
    If Cells(ActiveCell.Row, 12) <> "" Then 'si L vide
        tableau_client = ThisWorkbook.Sheets("ClientsCoordonnées").Range("Clients").Value
        ActiveSheet.Cells(ActiveCell.Row, 16).Value = rechercher_tab(tableau_client, Cells(ActiveCell.Row, 10), 3, 1) & " " & rechercher_tab(tableau_client, ActiveSheet.Cells(ActiveCell.Row, 10), 4, 1)
    End If
End If

Dim temp, entree As String
Dim macellule As Range
If Application.Intersect(Target, Range("$G$3:$H$30000")) Is Nothing Then Exit Sub
Application.MoveAfterReturn = False
For Each macellule In Target
    temp = ""

    If Not Application.Intersect(macellule, Range("$G$6:$G$30000")) Is Nothing Then
    Application.MoveAfterReturn = False
        'If Target.Count > 1 Then Exit Sub 'sortie si plusieurs cellules
        'If macellule.Value = "" Then Exit Sub 'sortie si vide
        If Left(macellule.Value, 2) = "33" And Len(macellule.Value) = 11 Then Exit Sub 'sortie si commence par 33
        entree = macellule.Value
        For I = 1 To Len(macellule.Value) 'boucle jusqu'à fin de mot
            If IsNumeric(Mid(entree, I, 1)) Then temp = temp & Mid(entree, I, 1)  'si caractère non numérique alors ajoute espace
        Next I
        If Left(temp, 1) = "0" Then temp = Right(temp, Len(temp) - 1)
        If Len(temp) <> 9 Then
            MsgBox "numéro invalide refaire votre saisie" & entree & "-" & temp
            'ActiveCell.Offset(0, 0).Select
            Target.FormulaR1C1 = ""
            Target.Select
        Else
            Application.EnableEvents = False
            ActiveSheet.Unprotect Password:=""
            macellule.Value = "33" & temp
        End If
    End If

    If Not Application.Intersect(macellule, Range("$H$6:$H$30000")) Is Nothing Then
    Application.MoveAfterReturn = False
        'If Target.Count > 1 Then Exit Sub 'sortie si plusieurs cellules
        'If macellule.Value = "" Then Exit Sub 'sortie si vide
        If Left(macellule.Value, 2) = "33" And Len(macellule.Value) = 11 Then Exit Sub 'sortie si commence par 33
        entree = macellule.Value
        For I = 1 To Len(macellule.Value) 'boucle jusqu'à fin de mot
            If IsNumeric(Mid(entree, I, 1)) Then temp = temp & Mid(entree, I, 1)  'si caractère non numérique alors ajoute espace
        Next I
        If Left(temp, 1) = "0" Then temp = Right(temp, Len(temp) - 1)
        If Len(temp) <> 9 Then
            MsgBox "numéro invalide refaire votre saisie" & entree & "-" & temp
            'ActiveCell.Offset(0, 0).Select
            Target.FormulaR1C1 = ""
            Target.Select
        Else
            Application.EnableEvents = False
            macellule.Value = "33" & temp
        End If
    End If
Next

    ActiveSheet.Protect Password:="", DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveSheet.EnableSelection = xlNoRestrictions
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.MoveAfterReturn = True
    Cells(1, 29) = Target.Value
    Cells(2, 29) = "x"
End Sub
Si vous vous demandez : ça fonctionne ça ??? hé ben oui lol
Merci de ne pas vous moquer lol
 
Vote positif 0 Vote négatif

sylvanu

XLDnaute Barbatruc
Supporter XLD
Lionel,
C'est pareil qu'expliqué au post #15.
Seulement dans votre cas il va parcourir tous les IF alors qu'avec des IF ELSEIF dès qu'il trouvera la bonne correspondance il la traitera et sortira sans se préoccuper des autres plages.
Mais si ce genre d'écriture vous va, elle marche impeccable.
 
Vote positif 0 Vote négatif

Usine à gaz

XLDnaute Barbatruc
J'ai tout simplement tenté ça :
VB: 
Private Sub Worksheet_SelectionChange(ByVal R As Range)
    If Not Intersect(R, Range("e6:s30000")) Is Nothing And R.CountLarge = 1 Then
    If R = Cells(ActiveCell.Row, 10) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 11) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 12) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 13) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 16) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 17) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 18) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 19) Then: Exit Sub
Il faudrait juste que ça bloque l'exécution de la suite du code, soit :
Code: 
       Application.EnableEvents = False
        [x2] = 0
        [x2].FormulaR1C1 = "=RIGHT(R[-1]C[-14],1)"
        Calculate
        If [x2] <> "K" Then
            ActiveSheet.Cells(Rows.Count, "e").End(xlUp)(1).Select
        'Rows("7:30000").RowHeight = 0
            Else
            [x2] = 0
            'Rows("7:30000").RowHeight = 50
        End If
        Application.EnableEvents = True
    End If
Mais ça me bloque l'exécution des codes suivants qui doivent s'éxécuter quand clic sur certaines cellules de la ligne.
 
Dernière édition:
Vote positif 0 Vote négatif

Usine à gaz

XLDnaute Barbatruc
Effectivement, je voudrais que :
VB: 
Private Sub Worksheet_SelectionChange(ByVal R As Range)
    If Not Intersect(R, Range("e6:s30000")) Is Nothing And R.CountLarge = 1 Then
    If R = Cells(ActiveCell.Row, 10) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 11) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 12) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 13) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 16) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 17) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 18) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 19) Then: Exit Sub
Me bloque le code jusque-là :
Code: 
Private Sub Worksheet_SelectionChange(ByVal R As Range)
    If Not Intersect(R, Range("e6:s30000")) Is Nothing And R.CountLarge = 1 Then
    If R = Cells(ActiveCell.Row, 10) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 11) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 12) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 13) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 16) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 17) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 18) Then: Exit Sub
    If R = Cells(ActiveCell.Row, 19) Then: Exit Sub

        Application.EnableEvents = False
        [x2] = 0
        [x2].FormulaR1C1 = "=RIGHT(R[-1]C[-14],1)"
        Calculate
        If [x2] <> "K" Then
            ActiveSheet.Cells(Rows.Count, "e").End(xlUp)(1).Select
        'Rows("7:30000").RowHeight = 0
            Else
            [x2] = 0
            'Rows("7:30000").RowHeight = 50
        End If
        Application.EnableEvents = True
    End If
mais ne bloque pas tout le code qui suit, me permettant ainsi d'exécuter les codes suivants qui doivent s'éxécuter quand clic sur certaines cellules de la ligne active.
 
Vote positif 0 Vote négatif

sylvanu

XLDnaute Barbatruc
Supporter XLD
Si j'ai bien compris, la première partie ne se fait pas si les colonnes sont entre 11 et 19. Le problème s'est qu'un Exit sub sort complétement de la macro.
Donc on peut faire le contraire :
Si la colonnes est <11 ou >19 on fait le code, sinon on poursuit. Dans ce cas il n'y a plus d'Exit sub.
VB: 
Private Sub Worksheet_SelectionChange(ByVal R As Range)
    If Not Intersect(R, Range("e6:s30000")) Is Nothing And R.CountLarge = 1 Then
    If R.Column <= 10 Or R.Column >= 20 Then ' Donc on exclut les colonnes de 10 à 19
        Application.EnableEvents = False
        [x2] = 0
        [x2].FormulaR1C1 = "=RIGHT(R[-1]C[-14],1)"
        Calculate
        If [x2] <> "K" Then
            ActiveSheet.Cells(Rows.Count, "e").End(xlUp)(1).Select
            Else
            [x2] = 0
        End If
        Application.EnableEvents = True
    End If
    ' Sinon on fait la suite
    ' ....  suite du code
 
Vote positif 0 Vote négatif

laurent950

XLDnaute Barbatruc
Bonsoir @Usine à gaz

' Erreur
VB: 
Private Sub Worksheet SelectionChange (ByVal R as Range)
     If Intersect (Active.Row, Range("j:s")) Is Nothing Then Exit Sub

' Correction
' A) Vous devriez utiliser Target.Row au lieu de Active.Row
' - De plus, vous pourriez vouloir spécifier les colonnes de la plage plutôt que de simplement mentionner les lettres.
' B) Dans cette version corrigée :
- Target.EntireRow est utilisé pour vérifier si la rangée sélectionnée (au lieu de la cellule) fait partie de la plage spécifiée (colonnes J à S).
- Cela permet de vérifier si la sélection est dans la plage J:S. Vous pouvez ensuite ajouter votre code à exécuter à l'intérieur de la procédure
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target.EntireRow, Range("J:S")) Is Nothing Then Exit Sub
    ' Votre code à exécuter ici
End Sub
 
Vote positif 0 Vote négatif

Usine à gaz

XLDnaute Barbatruc
Bsr sylvanu
Grand merci pour ta ténacité.
Aux 1ers tests, il semble que cela fonctionne.
Je dois faire d'autres tests mais trop fatigué pour ce soir.
Merci beaucoup pour tout ce que tu fais.
Bonne nuit,
lionel
 
Vote positif 0 Vote négatif

Usine à gaz

XLDnaute Barbatruc
Bonsoir Laurent,
Merci d'être là toi aussi mais on a déjà tenté "
Private Sub Worksheet_SelectionChange(ByVal Target As Range)"
Cliquez pour agrandir...


ça beugue car j'utilise déjà change cf photo ci-dessus.

Il semble que Sylvanu ait trouvé le bon code, cf #post 24.
Je poursuis demain
Bonne nuit,
lionel
 
Vote positif 0 Vote négatif

Usine à gaz

XLDnaute Barbatruc
Bonjour à toutes et à tous
Je reviens sur le sujet car "tout résolu" Par sylvanu que je remercie.
Merci aussi à ceux qui sont intervenu pour m'aider.
C'était coton comme beaucoup de mes demandes lol
Je joins le fichier qui fonctionne complètement.
 

Pièces jointes

  • compter vide test Sylvanu V6.xlsm
    33.8 KB · Affichages: 1
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

B
  • Question
Microsoft 365 Erreur d'exécution 35600
Réponses
4
Affichages
426
Dranreb
  • Résolu(e)
XL 2021 Cellule vide : sélectionner et atteindre
2
Réponses
15
Affichages
1 K
Usine à gaz
  • Résolu(e)
XL 2021 Sélectionner plusieurs plages jusqu'à la dernière ligne NON vide en col "E"
Réponses
5
Affichages
287
Usine à gaz
M
  • Question
XL 2021 Erreur 424
Réponses
14
Affichages
1 K
Marie1608
M
N
  • Résolu(e)
Microsoft 365 Code erreur dans code Vba
Réponses
14
Affichages
358
TooFatBoy
R
  • Question
XL 2021 Erreur 6 dépassement de capacité
Réponses
5
Affichages
255
patricktoulon
L
  • Question
XL 2021 formule
Réponses
3
Affichages
238
djidji59430
A
  • Question
XL 2016 erreur de code
Réponses
10
Affichages
307
AlphaOne
A
  • Résolu(e)
Microsoft 365 VBA - BeforeDoubleClick, 1ère cellule vide à partir de cellule active pour insertion de ligne
Réponses
4
Affichages
155
AlCapone
H
  • Question
XL 2013 Saisie sécurisée numéros de téléphone et ajout fonction clic droit de la souris
2
Réponses
21
Affichages
614
Helios77
H
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…