Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim s As Shape, f As Worksheet
nom = ActiveCell.Value
For Each f In Worksheets
For Each s In f.Shapes
s.Line.ForeColor.SchemeColor = 12
If s.Name = nom Then
s.Line.ForeColor.SchemeColor = 10
f.Activate
s.Select
End If
Next s
Next f
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column < 3 Then
Call Coloriage_Fleuve(Target.Value)
End If
End Sub
Sub Coloriage_Fleuve(LeFleuve As String)
Dim I As Byte
Dim J As Integer
Dim It
Dim Fleuve As Shape, Shp As Shape
Dim LesFleuves As Object
Set LesFleuves = CreateObject("Scripting.Dictionary")
For I = 2 To 5
With Sheets(I)
For Each Fleuve In .Shapes
LesFleuves.Item(Fleuve.Name) = I
Next Fleuve
End With
Next I
For Each It In LesFleuves.keys
If It = LeFleuve Then J = LesFleuves.Item(It): Exit For
Next It
If J = 0 Then Exit Sub
With Sheets(J)
For Each Shp In .Shapes
Shp.Line.ForeColor.SchemeColor = IIf(Shp.Name = It, 10, 12)
Next Shp
.Select
.[A1] = LeFleuve
End With
End Sub
Sub Rivière()
' Rivière Macro
' Macro enregistrée le 17/12/2009 par Gruick
Dim s As Shape, t
r = Application.Caller
With Sheets("BDD").Range("A:A")
Set rr = .Find(r, lookat:=xlWhole)
For Each s In ActiveSheet.Shapes
s.Line.ForeColor.SchemeColor = 12
If s.Name = rr Then s.Line.ForeColor.SchemeColor = 10
Next s
End With
[B]t = Time()[/B]
[B]Do[/B]
[B]DoEvents[/B]
[B]Loop While Time() < t + TimeSerial(0, 0, 1)[/B]
MsgBox (rr.Value & vbLf & "se jette dans " & rr.Offset(0, 1) _
& vbLf & "longueur " & rr.Offset(0, 2))
End Sub
Sub Rivière()
' Rivière Macro
' Macro enregistrée le 17/12/2009 par Gruick
Dim s As Shape
[COLOR=blue]Application.ScreenUpdating = False
[/COLOR]r = Application.Caller
With Sheets("BDD").Range("A:A")
Set rr = .Find(r, lookat:=xlWhole)
For Each s In ActiveSheet.Shapes
s.Line.ForeColor.SchemeColor = 12
If s.Name = rr Then s.Line.ForeColor.SchemeColor = 10
Next s
End With
[COLOR=blue]Application.ScreenUpdating = True
[/COLOR]MsgBox (rr.Value & vbLf & "se jette dans " & rr.Offset(0, 1) _
& vbLf & "longueur " & rr.Offset(0, 2))
End Sub