XL 2016 excel 2016 recherche dans toutes les zones de texte

[bricoulou]

Bonjour
Je souhaite chercher dans toutes les zones de texte et aussi comme la recherche classique d'excel mais dans toutes les feuilles du classeur
comment faudrait il faire (exemple, je cherche le mot "bidon" )
merci à vous et belle journée ;-)
val

 

[sylvanu]

Bonjour Bricoulon,
C'était fait exprès votre "Bldon" au lieu de "Bidon" dans votre zone de texte ? 🙂
Un essai en PJ avec :

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

 

[bricoulou]

Merci Sylvanu pour ta réponse super rapide !!!
je viens de l'essayer, il me répond sur la feuil 2, de ce fait bizarre ?:

Feuil1

$A$1

Je souhaiterai comme une recherche Excel qu'il se positionne sur les différents cellules ou zone de texte et que je puisse passer au suivant si ce n'est pas celui ci que je cherche, je n'ai peut etre pas été assez claire j'en suis désolée.
Pour le "bidon", lol, ce n'était pas fait exprès merci à ton œil de lynx ;-)
Bien à toi
Val

 

[sylvanu]

Oups, j'ai l'impression de ne pas avoir livré le bon fichier ! ( voir PJ1 )

Pour votre nouvelle demande, je regarde.

 

[sylvanu]

Re,
En PJ un essai.
Pour lancer la recherche vous faites ALT+F8 et lancer Rechercher. ( ou Développeur/Macros )

 

[crocrocro]

Bonjour brocoulou, sylvanu, le fil
sylvanu, je me suis permisd'apporter ces modifications à votre code :
- Test du type des TextBox et non du nom de la TextBox peu fiable
- Scroll si nécessaire pour avoir la TextBox toujours visible dans l'écran
- Utilisation de Rows.Count et Columns.Count et non de [A1:ZZ1000] pour balayer les cellules

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

 

[job75]

Bonjour à tous,

Pourquoi se casser la tête pour un truc aussi simple ? Des MsgBox suffisent s'il y a seulement quelques occurrences :

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

A+

 

[job75]

Avec des MsgBox à 2 boutons pour choisir la sélection :

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

 

[bricoulou]

CC Sylvanou, Crocrocro, Job75, le fil
ca marche nickel vos propositions, vous êtes au top !!!
Merci encore et passez une belle journée ;-)

 

[bricoulou]

Rebonjour à tous,
Nickel pour la recherche sur les cellule et les zones de textes
Par contre j'ai des zones de textes qui sont groupés, en ce cas, ces macros ne vont pas chercher dans ces zones de textes là exemple ci dessous :

Merki à vous, belle soirée à vous tous ;-)

 

[crocrocro]

La macro ChercherBis du post#6 modifiée pour tenir compte des regroupements

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

 

[job75]

Bonsoir à tous,

Par contre j'ai des zones de textes qui sont groupés

Ma macro du post #8 modifiée avec la collection GroupItems :

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

A+

 

[job75]

Si l'on veut que la Shape choisie soit sélectionnée ce n'est pas un problème.