Validation d'une shecklist

[scoubidou35]

Bonjour,
J'ai créé un fichier pour me permettre de trier plus rapidement. Pour cela je créé une liste (Cf. Feuille LISTE du fichier) des échantillons que je dois conserver et quand je scanne l'échantillon il m'indique si je dois jeter ou garder et si je garde il m'indique une nouvelle référence (Ref/) Mais dans la Feuille Shecklist j'ai fait une copie de la liste de départ et en fait j'aimerai si possible que quand je scanne un échantillon à garder (donc qui figure dans la liste de départ) il valide la shecklist et me mettant une croix dans la colonne validé. Ainsi s'il manque un échantillon que je puisse immédiatement l'identifier.
Je ne sais pas si j'ai été assez clair. Sinon n'hésitez pas à me le dire.
Merci
Sébastien

 

[scoubidou35]

Non il vaut mieux bien séparer pour être sûr de ne pas avoir des erreurs.

 

[Dranreb]

Non, il vaut mieux ne pas séparer, point final, je ne reviendrai pas là dessus, c'est à prendre ou à laisser.
Cette proposition sera ma dernière, elle ne se base que sur la feuille Validation :

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim CelA As Range, Scan, L As Long
     If Target.Address <> [Douchette].Address Then Exit Sub
     Application.EnableEvents = False
     Set CelA = Cells(Rows.Count, 1).End(xlUp)
     Scan = Target.Value
     CelA.Value = Scan
     On Error Resume Next
     L = WorksheetFunction.Match(Scan, Feuil4.[A4].Resize(Feuil4.[A1000000].End(xlUp).Row - 3), 0)
     If Err Then
         CelA.Offset(, 1).Value = Empty
         CelA.Offset(, 2).Value = "A JETER": JouerSonLong
     Else
         CelA.Offset(, 1).Value = Feuil4.[B4].Rows(L).Value
         CelA.Offset(, 2).Value = "OK": JouerSonCourt
         Feuil4.[C4].Rows(L).Value = Now: End If
     Target.ClearContents
     Target.Select
     Application.EnableEvents = True
End Sub

Libre à vous d'écrire une autre macro qui constitue cette veuille Validation par copie de données venues d'ailleurs.

 

[Dranreb]

Ou plus simplement :

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim Scan, L As Long
     If Target.Address <> [Douchette].Address Then Exit Sub
     Application.EnableEvents = False
     Scan = Target.Value
     [A5].Value = Scan
     On Error Resume Next
     L = WorksheetFunction.Match(Scan, Feuil4.[A4].Resize(Feuil4.[A1000000].End(xlUp).Row - 3), 0)
     If Err Then
         [B5].Value = Empty
         [C5].Value = "A JETER": JouerSonLong
     Else
         [B5].Value = Feuil4.[B4].Rows(L).Value
         [C5].Value = "OK": JouerSonCourt
         Feuil4.[C4].Rows(L).Value = Now: End If
     Target.ClearContents
     Target.Select
     Application.EnableEvents = True
End Sub

 

[Dranreb]

Perfectionnement possible :

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim Scan, L As Long
     If Target.Address <> [Douchette].Address Then Exit Sub
     Application.EnableEvents = False
     Scan = Target.Value
     [A5].Value = Scan
     On Error Resume Next
     L = WorksheetFunction.Match(Scan, Feuil4.[A4].Resize(Feuil4.[A1000000].End(xlUp).Row - 3), 0)
     If Err Then
         [B5].Value = Empty
         [C5].Value = "A JETER": JouerSonLong
     Else
         [B5].Value = Feuil4.[B4].Rows(L).Value
         [C5].Value = "OK": JouerSonCourt
         With Feuil4.[C4].Rows(L)
            If IsEmpty(.Value) Then
               .Value = Now
            ElseIf MsgBox("Déja validé le " & .Value & vbLf & "Remplacer date/heure ?", _
               vbExclamation + vbYesNo, "Scann") = vbYes Then
               .Value = Now: End If: End With: End If
     Target.ClearContents
     Target.Select
     Application.EnableEvents = True
End Sub

 

[Dranreb]

La version avec une autre API pour les sons :

Option Explicit
Private Declare Function MessageBeep Lib "user32.dll" (ByVal wType As Long) As Long

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim Scan, L As Long
     If Target.Address <> [Douchette].Address Then Exit Sub
     Application.EnableEvents = False
     Scan = Target.Value
     [A5].Value = Scan
     On Error Resume Next
     L = WorksheetFunction.Match(Scan, Feuil4.[A4].Resize(Feuil4.[A1000000].End(xlUp).Row - 3), 0)
     If Err Then
         [B5].Value = Empty
         [C5].Value = "A JETER": MessageBeep vbCritical
     Else
         [B5].Value = Feuil4.[B4].Rows(L).Value
         [C5].Value = "OK"
         With Feuil4.[C4].Rows(L)
            If IsEmpty(.Value) Then
               .Value = Now: MessageBeep vbInformation
            ElseIf MsgBox("Déja validé le " & .Value & vbLf & "Remplacer date/heure ?", _
               vbExclamation + vbYesNo, "Scann") = vbYes Then
               .Value = Now: End If: End With: End If
     Target.ClearContents
     Target.Select
     Application.EnableEvents = True
End Sub