Recherche sur plusieurs feuilles

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$C$5" Then 'cellule à adapter
  If Target <> "" Then
    Dim i As Integer, cel As Range
    For i = 2 To Worksheets.Count
      Set cel = Worksheets(i).Cells.Find(Target, , xlValues, xlWhole)
      If Not cel Is Nothing Then _
        Worksheets(i).Visible = True: Application.Goto cel: Exit Sub
    Next
    MsgBox "Pas trouvé..."
  End If
End If
End Sub

Sub CelluleSuivante()
'touches de raccourci Ctrl+S
If ActiveCell = "" Then Exit Sub
Static cel As Range 'mémorisation
Dim r As Range, i As Integer
If cel Is Nothing Then Set cel = ActiveCell
If ActiveSheet.Name <> cel.Parent.Name Then Set cel = ActiveCell
If ActiveCell <> cel Then Set cel = ActiveCell
Set r = ActiveSheet.Cells.Find(cel, ActiveCell, xlValues, xlWhole)
If r.Address <> cel.Address Then
  r.Select
Else
  For i = ActiveSheet.Index + 1 To Worksheets.Count
    Set cel = Worksheets(i).Cells.Find(ActiveCell)
    If Not cel Is Nothing Then
      Worksheets(i).Visible = True
      Application.Goto cel
      Exit Sub
    End If
  Next
  MsgBox "Pas de cellule suivante..."
End If
End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, _
ByVal Target As Range, Cancel As Boolean)
If Target <> "" Then Cancel = True: CelluleSuivante
End Sub

Private Sub Workbook_Activate()
Application.OnKey "~", "CelluleSuivante"
Application.OnKey "{ENTER}", "CelluleSuivante" 'pavé numérique
End Sub

Private Sub Workbook_Deactivate()
Application.OnKey "~"
Application.OnKey "{ENTER}"
End Sub

Sub CelluleSuivante()
Recherche xlNext
End Sub

Sub CellulePrecedente()
Recherche xlPrevious
End Sub

Sub Recherche(sens)
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If IsError(ActiveCell) Then MsgBox "Recherche impossible...": Exit Sub
If ActiveCell = "" Then Exit Sub
Dim cel As Range, r As Range, i As Integer
Set cel = ActiveSheet.Cells.Find(ActiveCell, , xlValues, xlWhole, , sens)
If sens = xlNext And ActiveSheet.[A1] = cel Then Set cel = ActiveSheet.[A1]
Set r = ActiveSheet.Cells.Find(cel, ActiveCell, , , , sens)
If r.Address <> cel.Address Then
  r.Select
Else
  i = IIf(sens = xlNext, 1, -1)
  For i = ActiveSheet.Index + i To IIf(i = 1, Worksheets.Count, 1) Step i
    Set cel = Worksheets(i).Cells.Find(r, SearchDirection:=sens)
    If Not cel Is Nothing Then
      If sens = xlNext And Worksheets(i).[A1] = r Then Set cel = Worksheets(i).[A1]
      Worksheets(i).Visible = True
      Application.Goto cel
      Exit Sub
    End If
  Next
  MsgBox "Pas de cellule " & IIf(i, "suivante...", "précédente...")
End If
End Sub

Set cel = ActiveSheet.Cells.Find(ActiveCell, , xlValues, xlWhole, , xlPrevious)
If sens = xlNext Then Set cel = ActiveSheet.Cells.Find(cel, cel)
'-----
    Set cel = Worksheets(i).Cells.Find(r, SearchDirection:=xlPrevious)
    If Not cel Is Nothing Then
      If sens = xlNext Then Set cel = Worksheets(i).Cells.Find(r, cel)

Sub CelluleSuivante()
Recherche xlNext
End Sub

Sub CellulePrecedente()
Recherche xlPrevious
End Sub

Sub Recherche(sens)
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If IsError(ActiveCell) Then MsgBox "Recherche impossible...": Exit Sub
If ActiveCell = "" Then Exit Sub
Static memcel As Range 'mémorisation
Dim cel As Range, r As Range, i As Integer
Set memcel = IIf(ActiveSheet.CodeName <> "Feuil1", memcel, Nothing)
If memcel Is Nothing Then Set memcel = ActiveCell
If ActiveCell.Find(memcel, , xlFormulas, xlWhole) Is Nothing _
  Then Set memcel = ActiveCell
Set cel = ActiveSheet.Cells.Find(memcel, SearchDirection:=xlPrevious)
If sens = xlNext Then Set cel = ActiveSheet.Cells.Find(memcel, cel)
Set r = ActiveSheet.Cells.Find(memcel, ActiveCell, , , , sens)
If r.Address <> cel.Address Then
  r.Select
Else
  i = IIf(sens = xlNext, 1, -1)
  For i = ActiveSheet.Index + i To IIf(i = 1, Worksheets.Count, 1) Step i
    Set cel = Worksheets(i).Cells.Find(memcel, SearchDirection:=xlPrevious)
    If Not cel Is Nothing Then
      If sens = xlNext Then Set cel = Worksheets(i).Cells.Find(memcel, cel)
      Worksheets(i).Visible = True
      Application.Goto cel
      Exit Sub
    End If
  Next
  MsgBox "Pas de cellule " & IIf(i, "suivante...", "précédente...")
End If
End Sub