mini moteur de recherche

Const MA_FEUILLE As String = "Base documentaire" 'modif pour une seule feuille

Type structTitresColonnnes
  Adresse As String
  Categorie As Variant
  Intitule As Variant
  Nature As Variant
  Inscription As Variant
  Cloture As Variant
  Sites As Variant
  Programmes As Variant
  Liens As Variant
End Type

Function Cherche(pmoWhat As String, pmoMatchCase As Boolean, pmoLookAt As Long) As Variant
Dim S As Worksheet
Dim R As Range
Dim First$
Dim Last$
Dim Colonnes() As structTitresColonnnes
Dim T()
Dim i&
Dim j&
Dim g&
Dim bool As Boolean
On Error GoTo Erreur
Application.EnableEvents = False
Application.DisplayAlerts = False
For Each S In ActiveWorkbook.Worksheets
  If S.Name = "tempo___pmo" Then
    S.Visible = xlSheetVisible
    S.Delete
    Exit For
  End If
Next S
For Each S In ActiveWorkbook.Worksheets
  
  If S.Name = MA_FEUILLE Then 'modif pour une seule feuille

    Set R = S.Cells.Find(after:=S.[iv65536], What:=pmoWhat, MatchCase:=pmoMatchCase, _
        LookAt:=pmoLookAt, SearchOrder:=xlByColumns)
    If Not R Is Nothing Then
      First$ = R.Address
      Last$ = First$
      GoSub Inscription
      Do
        Set R = S.Cells.FindNext(after:=S.Range(Last$))
        If Not R Is Nothing And R.Address <> First$ Then
          Last$ = R.Address
          GoSub Inscription
        End If
      Loop While Not R Is Nothing And R.Address <> First$
    End If
    
  End If  'modif pour une seule feuille
  
Next S
If bool Then
  Set S = Sheets.Add
  S.Name = "tempo___pmo"
  S.Visible = xlSheetVeryHidden
  ReDim T(1 To UBound(Colonnes), 1 To 9)
  For i& = 1 To UBound(T)
    With Colonnes(i&)
      T(i&, 1) = .Adresse
      T(i&, 2) = .Categorie
      T(i&, 3) = .Intitule
      T(i&, 4) = .Nature
      T(i&, 5) = .Inscription
      T(i&, 6) = .Cloture
      T(i&, 7) = .Sites
      T(i&, 8) = .Programmes
      T(i&, 9) = .Liens
    End With
  Next i&
  Set R = S.Range(S.Cells(1, 1), S.Cells(UBound(T, 1), UBound(T, 2)))
  R = T
  Cherche = R
End If
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Function
Erreur:
Application.DisplayAlerts = True
Application.EnableEvents = True
MsgBox "Erreur " & Err.Number & vbCrLf & vbCrLf & Err.Description
Exit Function
'--------------
Inscription:
bool = True
g& = g& + 1
ReDim Preserve Colonnes(1 To g&)
With Colonnes(g&)
  .Adresse = R.Parent.Name & "!" & R.Address(False, False)
  Set R = S.Range("a" & R.Row & "")
  .Categorie = R
  .Intitule = R.Offset(0, 1)
  .Nature = R.Offset(0, 2)
  .Inscription = R.Offset(0, 3)
  .Cloture = R.Offset(0, 4)
  .Sites = R.Offset(0, 5)
  .Programmes = R.Offset(0, 6)
  .Liens = R.Offset(0, 7)
End With
Return
End Function