XL 2016 excel 2016 recherche dans toutes les zones de texte

Sub Chercher()
Dim Chaine$, T, F, Sh, i%, N%
Application.ScreenUpdating = False
Chaine = [C4]
[B9:C1000].ClearContents
L = 1
Redim T(1 To 1000, 1 To 2)
'Pour toutes les feuilles
For Each F In Worksheets
    'Pour tous les shapes
    For Each Sh In Sheets(F.Name).Shapes
        'Si zone de texte alors on récupère les infos
        If Sh.Name Like "ZoneTexte*" Then
            If LCase(Sh.TextFrame.Characters.Text) Like "*" & LCase(Chaine) & "*" Then
                T(L, 1) = F.Name: T(L, 2) = Sh.Name: L = L + 1
            End If
        End If
    Next Sh
    On Error Resume Next
    'Pour toutes les feuilles hors Trouver
    If F.Name <> "Trouver" Then
        Sheets(F.Name).Select: [A1].Select
        'Combien y a t-il de "Chaine" ?
        N = Application.CountIf([A1:ZZ1000], "*" & Chaine & "*")
        'On recherche la 1ere
        Cells.Find(What:=Chaine, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
        'Et on récupère les autres
        For i = 1 To N
                Cells.FindNext(After:=ActiveCell).Activate
                T(L, 1) = F.Name: T(L, 2) = ActiveCell.Address: L = L + 1
        Next i
    End If
Next F
Sheets("Trouver").Select
'On restitue la matrice
[B9].Resize(UBound(T, 1), UBound(T, 2)) = T
End Sub

Sub ChercherBis()
Dim Chaine$, F, Sh, i%, N%, MaRange As Range
Chaine = InputBox("Quelle chaine recherchez vous ?")
If Chaine = "" Then Exit Sub
'Pour toutes les feuilles
For Each F In Worksheets
    F.Select
    'Pour tous les shapes
    For Each Sh In Sheets(F.Name).Shapes
        'Si zone de texte alors on récupère les infos
        If Sh.Type = msoTextBox Then
            If LCase(Sh.TextFrame.Characters.Text) Like "*" & LCase(Chaine) & "*" Then
                ActiveSheet.Shapes(Sh.Name).Select
                ScrollpCellule Sh.TopLeftCell
                DoEvents: Calculate
                Rep = MsgBox("Voulez vous le suivant ?", vbQuestion + vbYesNo + vbQuestion, "Recherche de : " & Chaine)
                If Rep <> 6 Then Exit Sub
            End If
        End If
    Next Sh
    
    On Error Resume Next

    'Combien y a t-il de "Chaine" ?
    Set MaRange = Range(Cells(1, 1), Cells(Rows.Count, Columns.Count))
    N = Application.CountIf(MaRange, "*" & Chaine & "*")
    If N > 0 Then
        'On recherche la 1ere
        Cells.Find(What:=Chaine, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
        'Et on récupère les autres
        For i = 1 To N
            Cells.FindNext(After:=ActiveCell).Activate
            ActiveCell.Select
            DoEvents: Calculate
            Rep = MsgBox("Voulez vous le suivant ?", vbQuestion + vbYesNo + vbQuestion, "Recherche de : " & Chaine)
            If Rep <> 6 Then Exit Sub
        Next i
    End If
Next F
End Sub

Sub ScrollpCellule(pCellule As Range)
' Suite à Suivant, on repositionne la textbox Active dans la fenêtre


    If pCellule.Column < ActiveWindow.Panes(1).ScrollColumn Then
        ActiveWindow.ScrollColumn = pCellule.Column
    Else
        Application.ScreenUpdating = False
        ActiveWindow.Panes(1).LargeScroll 0, 0, 1, 0
        If pCellule.Column > ActiveWindow.Panes(1).ScrollColumn Then
            ActiveWindow.Panes(1).LargeScroll 0, 0, -1, 0
            ActiveWindow.ScrollColumn = pCellule.Column
        Else
            ActiveWindow.Panes(1).LargeScroll 0, 0, -1, 0
        End If
        Application.ScreenUpdating = True
    End If
    If pCellule.Row < ActiveWindow.Panes(1).ScrollRow Then
        ActiveWindow.ScrollRow = pCellule.Row
    Else
        Application.ScreenUpdating = False
        ActiveWindow.Panes(1).LargeScroll 1, 0, 0, 0
        If pCellule.Row > ActiveWindow.Panes(1).ScrollRow Then
            ActiveWindow.Panes(1).LargeScroll -1, 0, 0, 0
            ActiveWindow.ScrollRow = pCellule.Row
        Else
            ActiveWindow.Panes(1).LargeScroll -1, 0, 0, 0
        End If
        Application.ScreenUpdating = True
    End If
End Sub

Sub Recherche()
Dim x As Variant, y$, w As Worksheet, c As Range, s As Shape
x = Application.InputBox("Entrez le texte, la casse sera ignorée :", "Recherche")
If x = False Or Trim(x) = "" Then Exit Sub
y = "*" & UCase(Trim(x)) & "*"
For Each w In Worksheets
    For Each c In w.UsedRange
        If UCase(Trim(c)) Like y Then MsgBox "Trouvé en " & w.Name & "!" & c.Address(0, 0), , "Recherche de " & x
    Next c
    On Error Resume Next
    For Each s In w.Shapes
        If Not UCase(Trim(s.TextFrame.Characters.Text)) Like y Then Else MsgBox "Trouvé en " & w.Name & "!" & s.TopLeftCell.Address(0, 0) & ", Shape " & s.Name, , "Recherche de " & x
Next s, w
End Sub

Sub Recherche()
Dim x As Variant, y$, w As Worksheet, c As Range, s As Shape
x = Application.InputBox("Entrez le texte, la casse sera ignorée :", "Recherche")
If x = False Or Trim(x) = "" Then Exit Sub
y = "*" & UCase(Trim(x)) & "*"
For Each w In Worksheets
    For Each c In w.UsedRange
        If UCase(Trim(c)) Like y Then
            w.Visible = xlSheetVisible 'au cas où
            Application.Goto c
            If MsgBox("Arrêt en " & w.Name & "!" & c.Address(0, 0) & " ?", vbYesNo, "Recherche de " & x) = vbYes Then End
        End If
    Next c
    On Error Resume Next
    For Each s In w.Shapes
        If Not UCase(Trim(s.TextFrame.Characters.Text)) Like y Then
        Else
            w.Visible = xlSheetVisible 'au cas où
            Application.Goto w.Range(s.TopLeftCell, s.BottomRightCell)
            If MsgBox("Arrêt en " & w.Name & "!" & Selection.Address(0, 0) & ", Shape " & s.Name & " ?", vbYesNo, "Recherche de " & x) = vbYes Then End
        End If
Next s, w
End Sub

Sub ChercherBis()
Dim Chaine$, F, Sh, Shi, i%, N%, MaRange As Range
Chaine = InputBox("Quelle chaine recherchez vous ?")
If Chaine = "" Then Exit Sub
'Pour toutes les feuilles
For Each F In Worksheets
    F.Select
    'Pour tous les shapes
    For Each Sh In Sheets(F.Name).Shapes
        'Si zone de texte alors on récupère les infos
        Select Case Sh.Type
        Case msoTextBox
            If LCase(Sh.TextFrame.Characters.Text) Like "*" & LCase(Chaine) & "*" Then
                ActiveSheet.Shapes(Sh.Name).Select
                ScrollpCellule Sh.TopLeftCell
                DoEvents: Calculate
                Rep = MsgBox(" Actuellement : " & Sh.Name & " .Voulez vous le suivant ?", vbQuestion + vbYesNo + vbQuestion, "Recherche de : " & Chaine)
                If Rep <> 6 Then Exit Sub
            End If
        Case msoGroup
            For Each Shi In Sh.GroupItems
                If Shi.Type = msoTextBox Then
                    If LCase(Shi.TextFrame.Characters.Text) Like "*" & LCase(Chaine) & "*" Then
                        ActiveSheet.Shapes(Shi.Name).Select
                        ScrollpCellule Sh.TopLeftCell
                        DoEvents: Calculate
                        Rep = MsgBox(" Actuellement : " & Shi.Name & " .Voulez vous le suivant ?", vbQuestion + vbYesNo + vbQuestion, "Recherche de : " & Chaine)
                        If Rep <> 6 Then Exit Sub
                    End If
                End If
            Next Shi
        End Select
    Next Sh
    
    On Error Resume Next

    'Combien y a t-il de "Chaine" ?
    Set MaRange = Range(Cells(1, 1), Cells(Rows.Count, Columns.Count))
    N = Application.CountIf(MaRange, "*" & Chaine & "*")
    If N > 0 Then
        'On recherche la 1ere
        Cells.Find(What:=Chaine, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
        'Et on récupère les autres
        For i = 1 To N
            Cells.FindNext(After:=ActiveCell).Activate
            ActiveCell.Select
            DoEvents: Calculate
            Rep = MsgBox("Voulez vous le suivant ?", vbQuestion + vbYesNo + vbQuestion, "Recherche de : " & Chaine)
            If Rep <> 6 Then Exit Sub
        Next i
    End If
Next F
End Sub

Sub Recherche()
Dim x As Variant, y$, w As Worksheet, c As Range, s As Shape, n, ss As Shape
x = Application.InputBox("Entrez le texte, la casse sera ignorée :", "Recherche")
If x = False Or Trim(x) = "" Then Exit Sub
y = "*" & UCase(Trim(x)) & "*"
For Each w In Worksheets
    For Each c In w.UsedRange
        If UCase(Trim(c)) Like y Then
            w.Visible = xlSheetVisible 'au cas où
            Application.Goto c
            If MsgBox("Arrêt en " & w.Name & "!" & c.Address(0, 0) & " ?", vbYesNo, "Recherche de " & x) = vbYes Then End
        End If
    Next c
    On Error Resume Next
    For Each s In w.Shapes
        n = 0
        n = s.GroupItems.Count
        If n Then
            For Each ss In s.GroupItems
                If Not UCase(Trim(ss.TextFrame.Characters.Text)) Like y Then
                Else
                    w.Visible = xlSheetVisible 'au cas où
                    Application.Goto w.Range(ss.TopLeftCell, ss.BottomRightCell)
                    If MsgBox("Arrêt en " & w.Name & "!" & Selection.Address(0, 0) & ", Shape " & ss.Name & " ?", vbYesNo, "Recherche de " & x) = vbYes Then End
                End If
            Next ss
        Else
            If Not UCase(Trim(s.TextFrame.Characters.Text)) Like y Then
            Else
                w.Visible = xlSheetVisible 'au cas où
                Application.Goto w.Range(s.TopLeftCell, s.BottomRightCell)
                If MsgBox("Arrêt en " & w.Name & "!" & Selection.Address(0, 0) & ", Shape " & s.Name & " ?", vbYesNo, "Recherche de " & x) = vbYes Then End
            End If
        End If
Next s, w
End Sub