XL 2016 Conditions VBA entre 2 colonnes

M

MickaeL_D

XLDnaute Junior
Bonjour,

Je souhaiterais ajouter une condition au code ci-dessous. Afin que la boite de dialogue s'affiche uniquement quand le chiffre 21 est rentré dans la colonne G.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xCell As Range, Rg As Range
On Error Resume Next
Set Rg = Application.Intersect(Target, Range("D6:D5000"))
If Not Rg Is Nothing Then
For Each xCell In Rg
If xCell.Value = "71076" Or xCell.Value = "605106" Or xCell.Value = "603149" Then
Dim Reponse As String
MsgBox "Renseigner la carte de ctrl CDC-CAU- 036 - Suivi masse après imprégnation tissu 711501", vbExclamation, "Remplir la carte de ctrl"
If Reponse = vbOK Then
ThisWorkbook.FollowHyperlink "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\ISOTEX\CDC-CAU- 036 - SUIVI MASSE ISOTEX APRES IMPREGNATION\CDC-CAU- 036 - Suivi masse après imprégnation.xlsx"
End If
End If
Next
End If
End Sub

Merci d'avance,
 
Solution
Bernard_XLD
cela donnerait quelque chose comme cela, pouvant être conjugué avec un select case pour envoyer des messages différents par valeur entrée


VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xCell As Range, Rg As Range
    On Error Resume Next
    Set Rg = Application.Intersect(Target, Range("G6:G5000"))
    If Not Rg Is Nothing Then
        For Each xCell In Rg
            If xCell.Value = 21 And (xCell.Offset(0, -3).Value = "71076" Or xCell.Offset(0, -3).Value = "605106" Or xCell.Offset(0, -3).Value = "603149") Then
                MsgBox "Renseigner la carte de ctrl CDC-CAU- 036 - Suivi masse après imprégnation tissu 711501", vbExclamation, "Remplir la carte de ctrl"
                ThisWorkbook.FollowHyperlink...
Trier par date Trier par votes
Bernard_XLD

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
Bonjour Mickael_D

J'ai aussi corrigé ton code, pas testé car pas de fichier joint

Cordialement
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xCell As Range, Rg As Range
    On Error Resume Next
    Set Rg = Application.Intersect(Target, Range("D6:D5000"))
    If Not Rg Is Nothing Then
        For Each xCell In Rg
            If xCell.Offset(0, 3).Value = 21 And (xCell.Value = "71076" Or xCell.Value = "605106" Or xCell.Value = "603149") Then
                Dim Reponse
                Reponse = MsgBox("Renseigner la carte de ctrl CDC-CAU- 036 - Suivi masse après imprégnation tissu 711501", vbExclamation, "Remplir la carte de ctrl")
                If Reponse = vbOK Then
                    ThisWorkbook.FollowHyperlink "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\ISOTEX\CDC-CAU- 036 - SUIVI MASSE ISOTEX APRES IMPREGNATION\CDC-CAU- 036 - Suivi masse après imprégnation.xlsx"
                End If
            End If
        Next
    End If
End Sub
 
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Mickael, et bienvenu sur XLD,
Essayez d'utiliser les balises </> cela rend le code plus lisible.
Un essai avec :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xCell As Range, Rg As Range
On Error Resume Next
Set Rg = Application.Intersect(Target, Range("D6:D5000"))
If Not Rg Is Nothing Then
    For Each xCell In Rg
        If (xCell.Value = "71076" Or xCell.Value = "605106" Or xCell.Value = "603149") And Cells(xCell.Row, "G") = 21 Then
            Dim Reponse As String
            MsgBox "Renseigner la carte de ctrl CDC-CAU- 036 - Suivi masse après imprégnation tissu 711501", vbExclamation, "Remplir la carte de ctrl"
            If Reponse = vbOK Then
                ThisWorkbook.FollowHyperlink "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\ISOTEX\CDC-CAU- 036 - SUIVI MASSE ISOTEX APRES IMPREGNATION\CDC-CAU- 036 - Suivi masse après imprégnation.xlsx"
            End If
        End If
    Next
End If
End Sub
En rajoutant dans le IF un AND Gxx=21.
Mais sans fichier test, c'est un peu en aveugle. :)
 
Vote positif 0 Vote négatif
Bernard_XLD

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
plus court mais pas testé non plus
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xCell As Range, Rg As Range
    On Error Resume Next
    Set Rg = Application.Intersect(Target, Range("D6:D5000"))
    If Not Rg Is Nothing Then
        For Each xCell In Rg
            If xCell.Offset(0, 3).Value = 21 And (xCell.Value = "71076" Or xCell.Value = "605106" Or xCell.Value = "603149") Then
                If MsgBox("Renseigner la carte de ctrl CDC-CAU- 036 - Suivi masse après imprégnation tissu 711501", vbExclamation, "Remplir la carte de ctrl") Then
                    ThisWorkbook.FollowHyperlink "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\ISOTEX\CDC-CAU- 036 - SUIVI MASSE ISOTEX APRES IMPREGNATION\CDC-CAU- 036 - Suivi masse après imprégnation.xlsx"
                End If
            End If
        Next
    End If
End Sub
 
Vote positif 0 Vote négatif
Bernard_XLD

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
Le dernier code que j'ai posté fonctionne parfaitement ou alors tu t'expliques mal sur ce que tu veux
quand on rentre des valeurs en colonne d, le message s'affiche bien uniquement si la valeur correspond à l'une des trois prévues et que la cellule correspondante en colonne G contient 21
j'ai modifié pour que le message affiche l'adresse de la cellule provoquant le message
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xCell As Range, Rg As Range
    On Error Resume Next
    Set Rg = Application.Intersect(Target, Range("D6:D5000"))
    If Not Rg Is Nothing Then
        For Each xCell In Rg
            If xCell.Offset(0, 3).Value = 21 And (xCell.Value = "71076" Or xCell.Value = "605106" Or xCell.Value = "603149") Then
                If MsgBox(xCell.Address & Chr(10) & "Renseigner la carte de ctrl CDC-CAU- 036 - Suivi masse après imprégnation tissu 711501", vbExclamation, "Remplir la carte de ctrl") Then
                    ThisWorkbook.FollowHyperlink "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\ISOTEX\CDC-CAU- 036 - SUIVI MASSE ISOTEX APRES IMPREGNATION\CDC-CAU- 036 - Suivi masse après imprégnation.xlsx"
                End If
            End If
        Next
    End If
End Sub
 

Pièces jointes

  • Copie de Test.xlsm
    16.6 KB · Affichages: 3
Vote positif 0 Vote négatif
M

MickaeL_D

XLDnaute Junior
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xCell As Range, Rg As Range
On Error Resume Next
Set Rg = Application.Intersect(Target, Range("D6:D5000"))
If Not Rg Is Nothing Then
For Each xCell In Rg
If xCell.Offset(0, 3).Value = 21 And (xCell.Value = "71076" Or xCell.Value = "605106" Or xCell.Value = "603149") Then
If MsgBox("Renseigner la carte de ctrl CDC-CAU- 036 - Suivi masse après imprégnation tissu 711501", vbExclamation, "Remplir la carte de ctrl") Then
ThisWorkbook.FollowHyperlink "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\ISOTEX\CDC-CAU- 036 - SUIVI MASSE ISOTEX APRES IMPREGNATION\CDC-CAU- 036 - Suivi masse après imprégnation.xlsx"
End If
End If
Next
End If
End Sub

Le code ci-dessus fonctionne mais il faut que je rentre "21" dans la colonne G. Puis, un des 3 autres codes dans la colonne D. Idéalement, il me faudrait l'inverse.

Merci d'avance,
 
Vote positif 0 Vote négatif
Bernard_XLD

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
Test modifié pour la colonne G
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xCell As Range, Rg As Range
    On Error Resume Next
    Set Rg = Application.Intersect(Target, Range("G6:G5000"))
    If Not Rg Is Nothing Then
        For Each xCell In Rg
            If xCell.Value = 21 And (xCell.Offset(0, -3).Value = "71076" Or xCell.Offset(0, -3).Value = "605106" Or xCell.Offset(0, -3).Value = "603149") Then
                If MsgBox("Renseigner la carte de ctrl CDC-CAU- 036 - Suivi masse après imprégnation tissu 711501", vbExclamation, "Remplir la carte de ctrl") Then
                    ThisWorkbook.FollowHyperlink "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\ISOTEX\CDC-CAU- 036 - SUIVI MASSE ISOTEX APRES IMPREGNATION\CDC-CAU- 036 - Suivi masse après imprégnation.xlsx"
                End If
            End If
        Next
    End If
End Sub
 

Pièces jointes

  • Copie de Test2.xlsm
    16.6 KB · Affichages: 6
Vote positif 0 Vote négatif
Bernard_XLD

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
je n'avais pas vu que tu n'attendais pas de validation de l'utilisateur pour lancer le lien, pas besoin donc de tester la réponse de la MsgBox
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xCell As Range, Rg As Range
    On Error Resume Next
    Set Rg = Application.Intersect(Target, Range("G6:G5000"))
    If Not Rg Is Nothing Then
        For Each xCell In Rg
            If xCell.Value = 21 And (xCell.Offset(0, -3).Value = "71076" Or xCell.Offset(0, -3).Value = "605106" Or xCell.Offset(0, -3).Value = "603149") Then
                MsgBox "Renseigner la carte de ctrl CDC-CAU- 036 - Suivi masse après imprégnation tissu 711501", vbExclamation, "Remplir la carte de ctrl"
                ThisWorkbook.FollowHyperlink "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\ISOTEX\CDC-CAU- 036 - SUIVI MASSE ISOTEX APRES IMPREGNATION\CDC-CAU- 036 - Suivi masse après imprégnation.xlsx"
            End If
        Next
    End If
End Sub
 
Vote positif 0 Vote négatif
M

MickaeL_D

XLDnaute Junior
J'aimerais ajouter à ce code une autre chose. En restant dans la même logique de msgbox + lien hypertexte.
Admettons en tapant "71073" dans la colonne D. Une autre msgbox devrait s'afficher avec un lien hypertexte. Sans tenir compte de la colonne G cette fois-ci.

Merci d'avance,
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Résolu(e)
XL 2016 Erreur de compilation "FOR"
Réponses
5
Affichages
851
MickaeL_D
M
M
  • Résolu(e)
XL 2016 Lien hyperlink ne s'ouvre pas
Réponses
2
Affichages
431
MickaeL_D
M

Membres actuellement en ligne

20 membres et 132 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 091
Messages
2 116 117
Membres
112 664
dernier inscrit
jujubaroude