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
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