XL 2016 Conditions VBA entre 2 colonnes

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
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...

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
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
 

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. :)
 

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
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
 

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
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

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,
 

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
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

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
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
 

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,
 

Discussions similaires

Statistiques des forums

Discussions
314 710
Messages
2 112 114
Membres
111 428
dernier inscrit
Andrya