XL 2021 Erreur d'exécution 424

Usine à gaz · 5 Février 2024

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

Usine à gaz · 5 Février 2024

sylvanu à dit:

Re,
C'est interdit tout simplement.
Il vous faut imbriquer les IF comme par ex :

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("J:S")) Is Nothing Then
        MsgBox "ok"
    ElseIf Not Intersect(Target, Plage2) Is Nothing Then
        'Code2
    ElseIf Not Intersect(Target, Plage3) Is Nothing Then
        'Code3
    ElseIf Not Intersect(Target, Plage4) Is Nothing Then
        'Code4
    End If
End Sub

Bon, je vais tenter de voir mais je ne sais pas faire ça.

sylvanu · 5 Février 2024

Mettez nous toutes vos Worksheet_SelectionChange.

Usine à gaz · 5 Février 2024

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

sylvanu · 5 Février 2024

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.

Usine à gaz · 5 Février 2024

Oui, ça m'irait mais je ne vois pas comment faire

Usine à gaz · 5 Février 2024

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.

sylvanu · 5 Février 2024

Ca veut dire que vous voulez faire deux actions sur certaines cellules ?

Usine à gaz · 5 Février 2024

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.

sylvanu · 5 Février 2024

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

laurent950 · 5 Février 2024

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

Usine à gaz · 5 Février 2024

sylvanu à dit:
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

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

Usine à gaz · 5 Février 2024

laurent950 à dit:
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

Bonsoir Laurent,
Merci d'être là toi aussi mais on a déjà tenté "

Private Sub Worksheet_SelectionChange(ByVal Target As Range)"

ç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

Usine à gaz · 9 Février 2024

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.

Effectuez une recherche sur Excel Downloads...

XL 2021 Erreur d'exécution 424

Usine à gaz

XLDnaute Barbatruc

Usine à gaz

XLDnaute Barbatruc

sylvanu

XLDnaute Barbatruc

Usine à gaz

XLDnaute Barbatruc

sylvanu

XLDnaute Barbatruc

Usine à gaz

XLDnaute Barbatruc

Usine à gaz

XLDnaute Barbatruc

sylvanu

XLDnaute Barbatruc

Usine à gaz

XLDnaute Barbatruc

sylvanu

XLDnaute Barbatruc

laurent950

XLDnaute Accro

Usine à gaz

XLDnaute Barbatruc

Usine à gaz

XLDnaute Barbatruc

Usine à gaz

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums