[VBA] Option de recherche dans une zone texte

flywinx

XLDnaute Nouveau
Bonjour,

Je possède un fichier Excel composé uniquement de zones de texte et je souhaiterai être capable de rechercher un mot pour savoir dans quelle zone de texte il se situe.

Pour cela j'ai créé un programme VBA à partir d'anciens messages de forums sur Excel.
Cependant celui-ci ne fonctionne pas puisque le résultat est toujours : "Aucun résultat trouvé".

Le code est le suivant :

VB:
Sub recherchecontenuzone()
Dim laShape As Shape, celluleCentre As Range, centreT As Double, centreL As Double, i As Long
Dim nbColAffichees As Long, nbLigAffichees As Long, decalageCol As Long, decalageLig As Long
Dim mot As String, laFeuille As Worksheet, trouve As Boolean

    'récupérer le mot à rechercher
  mot = InputBox("Mot à rechercher :", "Rechercher")
   
    trouve = False
    'boucler sur chaque feuille du classeur
   For Each laFeuille In ThisWorkbook.Sheets
    'boucler sur toutes les formes de la feuille
   For Each laShape In laFeuille.Shapes
    If laShape.Name Like "Text Box *" Then
    If laShape.TextFrame.Characters.Text Like "*" & mot & "*" Then trouve = True
    If trouve Then Exit For
    End If
    Next laShape
    If trouve Then Exit For
    Next laFeuille
   
    'si aucune forme contenant le numéro d'of n'a été trouvée, quitter la macro
  If laShape Is Nothing Then
                                MsgBox "Non trouvé"
                                Exit Sub
    End If
   
    'activer la feuille et sélectionner la forme
  laFeuille.Activate
    laShape.Select
   
    'centrer la forme à l'écran
  'calculer les "coordonnées" du centre de la forme
  centreT = laShape.Top + laShape.Height / 2
    centreL = laShape.Left + laShape.Width / 2
   
    'calculer la cellule correspondante aux "coordonnées"
  Set celluleCentre = Sheets(1).Range("A1")
       
    While celluleCentre.Offset(0, 1).Left < centreL
        Set celluleCentre = celluleCentre.Offset(0, 1)
    Wend
    While celluleCentre.Offset(1, 0).Top < centreT
        Set celluleCentre = celluleCentre.Offset(1, 0)
    Wend
   
    'vériffier le nombre de lignes et colonnes affichées
  nbColAffichees = ActiveWindow.VisibleRange.Columns.Count
    nbLigAffichees = ActiveWindow.VisibleRange.Rows.Count
   
    'calculer la cellule (colonne et ligne) à afficher en haut à droite
  decalageCol = IIf(celluleCentre.Column - CInt(nbColAffichees / 2) + 1 < 1, 1, celluleCentre.Column - CInt(nbColAffichees / 2) + 1)
    decalageLig = IIf(celluleCentre.Row - CInt(nbLigAffichees / 2) + 1 < 1, 1, celluleCentre.Row - CInt(nbLigAffichees / 2) + 1)
   
    'positionner la fenêtre (bugge depuis VBE, la macro doit être lancée depuis le excel)
  ActiveWindow.ScrollColumn = decalageCol
    ActiveWindow.ScrollRow = decalageLig
End Sub

Je pense qu'il y a un problème à ce niveau :

VB:
      If laShape.Name Like "Text Box *" Then
            If laShape.TextFrame.Characters.Text Like "*" & numOf & "*" Then trouve = True
            If trouve Then Exit For

Auriez-vous une solution à mon problème?

Je joins également à mon message un fichier exemple avec mes zones de texte.

Meric pour toute aide
 

Pièces jointes

  • exemple.xls
    132 KB · Affichages: 94
  • exemple.xls
    132 KB · Affichages: 98
  • exemple.xls
    132 KB · Affichages: 90

job75

XLDnaute Barbatruc
Re : [VBA] Option de recherche dans une zone texte

Bonjour flywinx,

Quand vous écrivez If laShape.Name Like "Text Box *" vous recherchez les Shapes dont le nom commence par "Text Box" (avec un espace).

Dans votre fichier aucun nom de Shape ne vérifie ce critère, vérifiez avec :

Code:
Sub a()
Dim s As Shape
For Each s In ActiveSheet.Shapes
MsgBox s.Name
Next
End Sub
Il y a tout de même "TextBox 46"...

A+
 

job75

XLDnaute Barbatruc
Re : [VBA] Option de recherche dans une zone texte

Re,

Pour la recherche du mot utilisez plutôt ce code :

Code:
For Each laFeuille In ThisWorkbook.Sheets
  For Each laShape In laFeuille.Shapes
    On Error Resume Next
    trouve = laShape.TextFrame.Characters.Text Like "*" & mot & "*"
    On Error GoTo 0
    If trouve Then Exit For
  Next
  If trouve Then Exit For
Next
A+
 

flywinx

XLDnaute Nouveau
Re : [VBA] Option de recherche dans une zone texte

Effectivement je te remercie pour ton aide, j'avais fait une mauvaise utilisation du like et de name. J'arrive maintenant à sélectionner la zone de texte qui contient le mot que je cherche.
Seulement je me demande s'il est possible de surligner également le mot ou juste de le sélectionner.

J'ai donc pensé lorsque le programme réalise la fonction suivante
Code:
    'activer la feuille et sélectionner la forme
  laFeuille.Activate
    laShape.Select

Si on ne peut pas à la place sélectionner le mot, en utilisant par exemple

Code:
laShape.TextFrame.Characters.Text Like "*" & mot & "*".Select

Seulement cette syntaxe n'est pas correcte et je ne sais donc pas comment sélectionner le mot à la place ou alors simplement le surligner.

Encore merci
 

flywinx

XLDnaute Nouveau
Re : [VBA] Option de recherche dans une zone texte

J'ai également pensé à utiliser la ligne de code

Code:
laShape.TextFrame.Characters.Text.Interior.ColorIndex = 6

mais lors du debug, j'ai un message d'erreur disant que le quantificateur Text est incorrect.

Je suis preneur de toute aide, merci :)
 

job75

XLDnaute Barbatruc
Re : [VBA] Option de recherche dans une zone texte

Re,

Ce que vous voulez faire est sans doute possible avec des contrôles ActiveX, ce qui n'est pas le cas ici.

Mais vous pouvez vous amuser avec un truc comme ça, à mettre en fin de macro :

Code:
With laShape.TextFrame.Characters(InStr(laShape.TextFrame.Characters.Text, mot), Len(mot)).Font
  .Size = 25
  .Bold = True
  .ColorIndex = 3
  Application.ScreenUpdating = True 'MAJ de l'écran
  Application.Wait Now + 5 / 86400 '5 secondes
  .Size = 10
  .Bold = False
  .ColorIndex = xlAutomatic
  Application.ScreenUpdating = True 'MAJ de l'écran
End With
A+
 

job75

XLDnaute Barbatruc
Re : [VBA] Option de recherche dans une zone texte

Re,

Perso j'utiliserais cette macro :

Code:
Option Compare Text 'la casse est ignorée

Sub recherchecontenuzone()
Dim mot As String, laFeuille As Object, laShape As Shape, trouve As Boolean
mot = InputBox("Mot à rechercher :", "Rechercher")
If mot = "" Then Exit Sub
On Error Resume Next
For Each laFeuille In Sheets
  For Each laShape In laFeuille.Shapes
    trouve = laShape.TextFrame.Characters.Text Like "*" & mot & "*"
    If trouve Then GoTo 1
  Next
Next
1 On Error GoTo 0
If Not trouve Then MsgBox "Non trouvé": Exit Sub
laFeuille.Visible = True 'si la feuille est masquée
Application.Goto laShape.TopLeftCell, True 'cadrage
With laShape.TextFrame.Characters(InStr(laShape.TextFrame.Characters.Text, mot), Len(mot)).Font
  .Size = 25
  .Bold = True
  .ColorIndex = 3
  Application.ScreenUpdating = True 'MAJ de l'écran
  Application.Wait Now + 5 / 86400 '5 secondes
  .Size = 10
  .Bold = False
  .ColorIndex = xlAutomatic
  Application.ScreenUpdating = True 'MAJ de l'écran
End With
End Sub
Fichier joint.

Edit 1 : ajouté laFeuille.Visible = True au cas où la feuille serait masquée.

Edit 2 : ajouté en haut du module Option Compare Text pour que la casse ne soit pas prise en compte.

A+
 

Pièces jointes

  • Shapes(1).xls
    128.5 KB · Affichages: 90
  • Shapes(1).xls
    128.5 KB · Affichages: 91
  • Shapes(1).xls
    128.5 KB · Affichages: 89
Dernière édition:

flywinx

XLDnaute Nouveau
Re : [VBA] Option de recherche dans une zone texte

ReBonjour,

Merci pour ton code simplifié job75, il marche parfaitement.

Aujourd'hui un problème auquel je n'avais pas pensé est survenu, et pourtant il est bien bête, parfois le mot que je recherche se trouve dans plusieurs zone de texte et j'aimerais continué la recherche s'il a déjà été trouvé dans une zone de texte.

Pour cela je pensais faire une boucle sur les formes laShape afin de continuer à rechercher le mot dans les autres formes, mais je ne vois pas vraiment comment faire.

Egalement, dans le code précédent, lorsque le mot est trouvé, la zone de texte est sélectionné et le mot est mis en gras et en jaune pendant une période de 5s puis revient à sa typographie originelle. J'aimerais modifier ce paramètre de temps pour le remplacer par l'appui sur une touche (par exemple entrée) avant de changer la police et la couleur du même mot trouvé mais dans une autre zone de texte.

Voila pour l'instant le code auquel j'ai pensé.

Code:
Option Explicit
Option Compare Text 'la casse est ignorée

Sub Macro1()
Dim mot As String, laFeuille As Object, laShape As Shape, trouve As Boolean, KeyCode As MSForms.ReturnInteger


mot = InputBox("Mot à rechercher :", "Rechercher")    'récupérer le mot à rechercher
If mot = "" Then Exit Sub
On Error Resume Next

For Each laFeuille In Sheets      'boucler sur toutes les feuilles
  For Each laShape In laFeuille.Shapes      'boucler sur toutes les formes de la feuille
    trouve = laShape.TextFrame.Characters.Text Like "*" & mot & "*"
    If trouve Then GoTo 1
  Next
Next
1 On Error GoTo 0

'si aucune forme contenant le numéro d'of n'a été trouvée, quitter la macro
If Not trouve Then MsgBox "Non trouvé": Exit Sub

laFeuille.Visible = True 'si la feuille est masquée
Application.Goto laShape.TopLeftCell, True 'cadrage
With laShape.TextFrame.Characters(InStr(laShape.TextFrame.Characters.Text, mot), Len(mot)).Font
  .Size = 12    'mettre la police du mot recherché et trouvé à 12
  .Bold = True  'mettre le mot en gras
  .ColorIndex = 6      'mettre le mot en jaune
      If KeyCode = 13 Then
        .Size = 10   'remettre la police à 10
        .Bold = False     'enlever le paramètre gras
        .ColorIndex = xlAutomatic     'remettre la couleur originelle du mot
        Application.ScreenUpdating = True 'MAJ de l'écran
    End If
End With
    ActiveWorkbook.Save
    Application.Run "'Shapes(1).xls'!Macro1"
End Sub

Ma question serait alors, comment continué la recherche sur toutes les formes jusqu'à ce que le mot recherché ne soit plus trouvé et comment corriger la fonction If Keycode=13 then blablabla que j'utilise?

Encore merci à ceux qui voudront bien m'aider
 

Pièces jointes

  • Shapes(2).xls
    109 KB · Affichages: 67
  • Shapes(2).xls
    109 KB · Affichages: 68
  • Shapes(2).xls
    109 KB · Affichages: 65

job75

XLDnaute Barbatruc
Re : [VBA] Option de recherche dans une zone texte

Bonjour flywinx,

Il suffit de ne pas sortir des boucles For Each :

Code:
Sub recherchecontenuzone()
Dim mot As String, laFeuille As Object, laShape As Shape
Dim trouve As Boolean, vu As Boolean, adr As String
mot = InputBox("Mot à rechercher :", "Rechercher")
If mot = "" Then Exit Sub
For Each laFeuille In Sheets
  For Each laShape In laFeuille.Shapes
    trouve = False
    On Error Resume Next
    trouve = laShape.TextFrame.Characters.Text Like "*" & mot & "*"
    On Error GoTo 0
    If trouve Then
      vu = True 'pour le message
      laFeuille.Visible = True 'si la feuille est masquée
      Application.Goto laShape.TopLeftCell, True 'cadrage
      With laShape.TextFrame.Characters(InStr(laShape.TextFrame.Characters.Text, mot), Len(mot)).Font
        .Size = 25
        .Bold = True
        .ColorIndex = 3
        Application.ScreenUpdating = True 'MAJ de l'écran
        adr = ActiveCell.Address
        While ActiveCell.Address = adr: DoEvents: Wend
        .Size = 10
        .Bold = False
        .ColorIndex = xlAutomatic
        Application.ScreenUpdating = True 'MAJ de l'écran
      End With
    End If
  Next
Next
If Not vu Then MsgBox "Non trouvé"
End Sub
Par ailleurs la temporisation de 5 secondes a été remplacée par :

Code:
adr = ActiveCell.Address
While ActiveCell.Address = adr: DoEvents: Wend
La boucle While s'exécute tant qu'on ne change pas de cellule active (touche Entrée ou autre).

Fichier (2).

A+
 

Pièces jointes

  • Shapes(2).xls
    129.5 KB · Affichages: 80
  • Shapes(2).xls
    129.5 KB · Affichages: 82
  • Shapes(2).xls
    129.5 KB · Affichages: 69

flywinx

XLDnaute Nouveau
Re : [VBA] Option de recherche dans une zone texte

Une dernière question et je vous laisse tranquille, surtout job75. Lors de la recherche du mot et de sont affichage en gras, grand et rouge, si la recherche est concluante, après un appui sur entrée par exemple, la recherche va passer au résultat trouvé suivant. Seulement si le mot que je cherchais était le bon j'aimerais attribuer à la touche Echap l'action de quitter la macro.

Pour celà j'ai déclaré :
Code:
Dim KeyAscii As Integer

et je veux rajouté l'action :
Code:
  If KeyAscii = vbKeyEscape Then Exit Sub
en réinitialisant si-possible la police et la couleur du mot pour quitter la macro.

J'ai voulu placer cette ligne de code dans le While en codant :
Code:
adr = ActiveCell.Address
While (ActiveCell.Address = adr)
            If KeyAscii = vbKeyEscape Then Exit Sub
            DoEvents 'Ici on appuie sur une touche pour continuer la recherche
Wend

Mais cela ne fonctionne pas. Auriez-vous une solution s'il vous plait?
 

Pièces jointes

  • Shapes(3).xls
    129.5 KB · Affichages: 61
  • Shapes(3).xls
    129.5 KB · Affichages: 69
  • Shapes(3).xls
    129.5 KB · Affichages: 67

job75

XLDnaute Barbatruc
Re : [VBA] Option de recherche dans une zone texte

Re,

Avec la touche <Echap> on ne peut rien faire, mais OK avec la touche de direction <Droite> :

Code:
If ActiveCell.Address = Range(adr)(1, 2).Address Then End 'arrête la macro
Fichier (3).

A+
 

Pièces jointes

  • Shapes(3).xls
    129.5 KB · Affichages: 82
  • Shapes(3).xls
    129.5 KB · Affichages: 76
  • Shapes(3).xls
    129.5 KB · Affichages: 77
Dernière édition:

flywinx

XLDnaute Nouveau
Re : [VBA] Option de recherche dans une zone texte

S'il y a des gens que ça intéresse, je me permets de poster le code complet (grâce à job75) et commenté qui permet donc de lancer une recherche dans une zone de texte sur Excel.


Code:
Option Explicit
Option Compare Text 'la casse est ignorée
Public arret As Boolean

Sub RechercheContenuZoneTexte()
Dim mot As String, laFeuille As Object, laShape As Shape
Dim trouve As Boolean, vu As Boolean, adr As String

mot = InputBox("Mot à rechercher :" & vbLf & vbLf & vbLf & vbLf & "Note : Appuyer sur entrée pour continuer la recherche." & vbLf & vbLf & "Appuyer sur la flèche de droite pour arrêter la recherche.", "Rechercher") 'récupérer le mot à rechercher

If mot = "" Then Exit Sub

For Each laFeuille In Sheets                    'boucler sur toutes les feuilles
  For Each laShape In laFeuille.Shapes          'boucler sur toutes les formes de la feuille
    trouve = False
    On Error Resume Next
    trouve = laShape.TextFrame.Characters.Text Like "*" & mot & "*"
    On Error GoTo 0
    If trouve Then
      vu = True 'pour le message
      laFeuille.Visible = True 'si la feuille est masquée
      Application.Goto laShape.TopLeftCell, True 'cadrage
      With laShape.TextFrame.Characters(InStr(laShape.TextFrame.Characters.Text, mot), Len(mot)).Font
        .Size = 14          'mettre la police du mot recherché et trouvé à 12
        .Bold = True        'mettre le mot en gras
        .ColorIndex = 7     'mettre le mot en violet
        Application.ScreenUpdating = True 'MAJ de l'écran
        adr = ActiveCell.Address     'La boucle While s'exécute tant qu'on ne change pas de cellule active (touche Entrée ou autre)
        While ActiveCell.Address = adr: DoEvents: Wend    'Ici on appuie sur entrée pour continuer la recherche
        .Size = 10          'remettre la police à 10
        .Bold = False       'enlever le paramètre gras
        .ColorIndex = xlAutomatic   'remettre la couleur originelle du mot
        Application.ScreenUpdating = True 'MAJ de l'écran
        If ActiveCell.Address = Range(adr)(1, 2).Address Then End 'arrête la macro lorsqu'on appuie sur la flèche de droite
      End With
    End If
  Next
Next
If Not vu Then MsgBox "Non trouvé"  'si aucune forme contenant le mot n'a été trouvée, quitter la macro

End Sub
 

Discussions similaires

Réponses
16
Affichages
981

Statistiques des forums

Discussions
311 729
Messages
2 081 970
Membres
101 852
dernier inscrit
dthi16088