Faire un recherche VBA

bonjour à toutes et à tous,

je suis débutant dans excel et surtout en VBA.

je voudrais faire un fichier avec plusieurs thèmes

je souhaiterai faire une recherche de texte par rapport à un mot et quand il trouve le mot, je souhaiterai qu'il se positionne sur l'onglet et le mot qu'il a trouvé .

je vous met le fichier en exemple, pour l'instant , il y a l'onglet MENU et sur l'onglet Feuille 2 qui il y a quelque chose pour l'instant.

merci de votre aide

Bonjour,

Ci-après une proposition.

Remarques :

La recherche s'arrete au premier mot trouvé, elle ne les cherche pas tous.

J'ai vu que le mot recherché était mis en gras dans votre fichier. N'étant pas précisé dans la demande (étant donné que c'est un peu compliqué à ajouter) je ne l'ai pas implémenté. Vous avez simplement l'adresse de la cellule donnée en D3 et la cellule correspondante est sélectionnée si trouvée.

Ci-dessous le code correspondant :

Option Explicit

Private inputRng As Range

Function SearchWord(word As String, wksheet As Worksheet) As Range
  ' searching the word in all the cells of the worksheet
  Dim searchField As Range
  With wksheet
    Set searchField = .Range(.Range("A1"), _
                             .Range("A1").End(xlDown).End(xlToRight))
  End With
  ' selecting only the non-empty cells containing Text
  On Error GoTo emptySheet
  Set searchField = searchField.SpecialCells(xlCellTypeConstants, 2)

  Dim cell As Range
  For Each cell In searchField
    If InStr(1, cell.Value2, word, vbTextCompare) > 0 Then
      ' found the searched word
      Set SearchWord = cell
      Exit Function
    End If
  Next cell

  ' if not found (or empty sheet), returning the initial range = menu/D4
emptySheet:
  On Error GoTo 0
  Set SearchWord = inputRng
End Function

Sub ClickFind()
  Application.ScreenUpdating = False

  initialize

  Dim searchedWord As String
  searchedWord = inputRng.Value2

  Dim wksheet As Worksheet
  For Each wksheet In ThisWorkbook.Worksheets
    If wksheet.Name <> "menu" Then
      Dim foundRng As Range
      Set foundRng = SearchWord(searchedWord, wksheet)
      If foundRng.Address <> inputRng.Address Then
        ' word found
        inputRng.Offset(-1, 0).Value2 = "Mot trouvé en " _
                                      & wksheet.Name & "!" & foundRng.Address
        wksheet.Select
        foundRng.Select
        Exit Sub
      End If
    End If
  Next wksheet

  ' word not found
  inputRng.Offset(-1, 0).Value2 = "Mot non trouvé"
End Sub

Sub initialize()
  Set inputRng = ThisWorkbook.Worksheets("menu").Range("D4")
End Sub

bonjour,

cela me convient, ca va faciliter mon travail

merci pour votre réponse.

bon courage et à bientôt

Bonjour;

Ici tous les mots recherchés sont trouvés:

Cdlt

bonjour,

merci pour votre aide,

effectivement, cela me parait plus fonctionnel

a plus

Re,

Proposition de Arturo83 certainement plus simple à appréhender mais attention, elle ne vérifie que la colonne 1 de la feuille 2 or il me semble que vous cherchiez à vérifier l'ensemble des cellules de toutes les feuilles, d'ou mon approche assez différente et le choix de s'arreter au premier "match".

Mais je conviens que l'approche de lecture complète du texte des cellules permet un retour plus intéressant, meme si non spécifié dans votre demande.

Dans tous les cas n'oubliez pas de marquer le topic comme résolu si l'une des solutions vous convient.

bonjour ,effectivement, j'aurai préféré que ca recherche sur toutes les feuilles mais plus si possible.

a plus

Bonjour,

SI vous voulez l'appliquer sur toutes les feuilles, voici:

le code modifié:

Option Compare Text

Sub Rechercher_Texte()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim x As Variant
    Dim Mot As String, FirstMot As String
    Dim NbCar As Long, Pos As Long, NbMot As Long, i As Long
    Application.ScreenUpdating = False
    Set f1 = Sheets("menu")

    For i = 1 To Sheets.Count
        If Sheets(i).Name <> "menu" Then
            Set f2 = Sheets(Sheets(i).Name)
            Mot = f1.Range("D4").Value
            NbCar = Len(Mot)
            With f2.Columns(1)
                .Font.ColorIndex = 1
                Set x = .Find(Mot)
                If Not x Is Nothing Then
                    FirstMot = x.Address
                    Do
                        Pos = 1
                        NbMot = (Len(f2.Cells(x.Row, "A")) - Len(Replace(f2.Cells(x.Row, "A"), Mot, ""))) / NbCar
Suivant:
                        NwPos = InStr(Pos, f2.Cells(x.Row, "A"), Mot, 1)
                        f2.Cells(x.Row, "A").Characters(Start:=NwPos, Length:=NbCar).Font.ColorIndex = 3
                        Do While NbMot > 1
                            Pos = NwPos + Len(Mot) + 1
                            NwPos = InStr(Pos, f2.Cells(x.Row, "A"), Mot, 1)
                            f2.Cells(x.Row, "A").Characters(Start:=NwPos, Length:=NbCar).Font.ColorIndex = 3
                            NbMot = NbMot - 1
                        Loop
                        Set x = .FindNext(x)
                    Loop While Not x Is Nothing And x.Address <> FirstMot
                End If
            End With
        End If
    Next i
    Set f1 = Nothing
    Set f2 = Nothing
    Set x = Nothing
End Sub

Cdlt

Bonjour,

Ci-après la macro de Arturo éditée pour s'appliquée à l'ensemble des cellules (soit toutes les colonnes) de toutes les feuilles du classeur.

EDIT 11h40 : remplacement de l'appel de f2.cells(x) par x directement

Option Compare Text

Sub Rechercher_Texte()
  Dim f1 As Worksheet, f2 As Worksheet
  Dim x As Variant
  Dim Mot As String, FirstMot As String
  Dim NbCar As Long, Pos As Long, NbMot As Long
  Application.ScreenUpdating = False

  Set f1 = ThisWorkbook.Worksheets("menu")

  Dim i As Long
  For i = 2 To ThisWorkbook.Worksheets.Count
    Set f2 = ThisWorkbook.Worksheets(i)

    Mot = f1.Range("D4").Value
    NbCar = Len(Mot)

    With f2.Cells
      .Font.ColorIndex = 1

      Set x = .Find(Mot)

      If Not x Is Nothing Then
        FirstMot = x.Address
        Do
          Pos = 1
          ' nb mots = ( longueurTxt - longueurTxt_noMot ) / longueurMot
          NbMot = (Len(x) - Len(Replace(x, Mot, ""))) / NbCar
Suivant:
          NwPos = InStr(Pos, x, Mot, 1)

          ' chgnt couleur
          x.Characters(Start:=NwPos, Length:=NbCar).Font.ColorIndex = 3

          Do While NbMot > 1                     ' for i = 1 to ...
            Pos = NwPos + Len(Mot) + 1
            NwPos = InStr(Pos, x, Mot, 1)

            ' chgnt couleur mots supplémentaires
            x.Characters(Start:=NwPos, Length:=NbCar).Font.ColorIndex = 3
            NbMot = NbMot - 1
          Loop
          Set x = .FindNext(x)
        Loop While Not x Is Nothing And x.Address <> FirstMot
      End If
    End With
  Next i
End Sub

bonjour,

merci pour votre aide, je vais regarder le fichier.

bonne journée

bonjour saboh 12617,

votre macro fonctionne bien quand il trouve un mot il ne me met pas sur la feuille qu'il a trouvé,

j'ai essayé de le modifier mais ca ne marche pas, pouvez vous m'arranger cela

merci pour votre patience

Sous

FirstMot = x.Address

Ajoutez

FirstMot = x.Address
x.Parent.Select
x.Select

Ca vous sélectionnera la dernière cellule dans laquelle le mot a été trouvé.

Bonjour Ced21,

Visiblement vous n'avez pas vu ma réponse à11h36, Je vous remets le fichier avec en plus, la recherche sur plusieurs cellules de chaque feuille.

le code n'en demeure pas moins toujours aussi court:

Option Compare Text

Sub Rechercher_Texte()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim x As Variant
    Dim Mot As String, FirstMot As String
    Dim NbCar As Long, Pos As Long, NbMot As Long, i As Long
    Dim DerLig As Long, DerCol As Long
    Dim Plage As Range, cell As Range
    Application.ScreenUpdating = False
    Set f1 = Sheets("menu")

    For i = 1 To Sheets.Count
        If Sheets(i).Name <> "menu" Then
            Set f2 = Sheets(Sheets(i).Name)
            Mot = f1.Range("D4").Value
            DerCol = f2.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            DerLig = f2.Cells.Find("*", , , , xlByRows, xlPrevious).Row
            Set Plage = Range(f2.Cells(1, 1), f2.Cells(DerLig, DerCol))
            NbCar = Len(Mot)
            For Each cell In Plage
                cell.Font.ColorIndex = 1
                Set x = Plage.Find(Mot)
                If Not x Is Nothing Then
                    FirstMot = x.Address
                    Do
                        Pos = 1
                        NbMot = (Len(cell) - Len(Replace(cell, Mot, ""))) / NbCar
Suivant:
                        NwPos = InStr(Pos, cell, Mot, 1)
                        cell.Characters(Start:=NwPos, Length:=NbCar).Font.ColorIndex = 3
                        Do While NbMot > 1
                            Pos = NwPos + Len(Mot) + 1
                            NwPos = InStr(Pos, cell, Mot, 1)
                            cell.Characters(Start:=NwPos, Length:=NbCar).Font.ColorIndex = 3
                            NbMot = NbMot - 1
                        Loop
                        Set x = Plage.FindNext(x)
                    Loop While Not x Is Nothing And x.Address <> FirstMot
                End If
            Next
        End If
    Next i
    Set f1 = Nothing
    Set f2 = Nothing
    Set x = Nothing
    Set Plage = Nothing
End Sub

Cdlt

merci

bonjour Arturo 83

j'ai essayé le fichier, il fonctionne bien.

est ce qu'il serait possible que quand il trouve le mot, il se met sur l'onglet et sur la phrase?

Bonjour,

Oui bien sûr, mais si le mot recherché est présent sur plusieurs feuilles et/ou plusieurs cellules, ce sera la dernière feuille et la dernière cellule qui seront affichées.

Cdlt

bonjour,

merci pour votre retour, je vais regardé.

merci et bon weekend