Option Compare Text 'la casse est ignorée
Private Sub Worksheet_Activate()
'mise à jour pour le cas où l'on a supprimé des feuilles
Worksheet_Change [E7]
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [E7,E9,E11,E13]) Is Nothing Then
Dim a, b$(), mem#(), i%, w As Worksheet, c As Range
a = Array("*" & [E7] & "*", [E9], [E11], [E13]) 'adaptable
ReDim b(UBound(a)): ReDim mem(UBound(a))
For i = 1 To UBound(a): mem(i) = 9 ^ 9: Next
For Each w In Worksheets
If a(0) <> "**" And w.[C6] Like a(0) Then b(0) = b(0) & w.Name & ","
For i = 1 To UBound(a)
Set c = w.Range("C" & i + 6)
If a(i) <> "" And c <> "" And Abs(c - a(i)) < mem(i) Then mem(i) = Abs(c - a(i)): b(i) = w.Name
Next
Next
'---restitutions---
With [F7].Validation
.Delete
[F7] = ""
If b(0) <> "" Then .Add xlValidateList, Formula1:=Left(b(0), Len(b(0)) - 1)
End With
[F9] = b(1): [F11] = b(2): [F13] = b(3)
If Not Intersect(Target, [E7]) Is Nothing And [E7] <> "" Then
[F7].Select
ElseIf Not Intersect(Target, [E9,E11,E13]) Is Nothing Then
Target.Select
End If
ElseIf Not Intersect(Target, [F7]) Is Nothing And [F7] <> "" Then
Application.Goto Sheets([F7].Value).[C6]
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(ActiveCell, [F9,F11,F13]) Is Nothing Or ActiveCell = "" Then Exit Sub
With ActiveCell
.Offset(, -1).Select
Application.Goto Sheets(.Value).Cells(7 + (.Row - 9) / 2, 3)
End With
End Sub
