' *** Référence : Microsoft Excel 11.0 Object Library (ou équivalent)
Public Function FindWord(ByVal sWord As String, ByVal sPathAndFileName As String, ByVal sSheet As String, Optional vPlage As Variant) As String()
Dim bVerifPlage As Boolean, bFileNotRunning As Boolean
Dim rStartCell As Range, rPlage As Range
Dim xlApp As Excel.Application, xlBook As Object, xlSheet As Worksheet
On Error Resume Next
xlBook = GetObject(sPathAndFileName, "Excel.Aplication")
If Err.Number <> 0 Then
Err.Clear: bFileNotRunning = True
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Open(sPathAndFileName)
Else
Set xlApp = GetObject(, "Excel.Application")
End If
On Error GoTo 0
xlBook.Sheets(sSheet).Select
If Not IsMissing(vPlage) Then bVerifPlage = True
'vérification d'une possible plage
Dim cMyAddress As New Collection
Dim sRes() As String
Dim ParseRange() As String
If bVerifPlage = False Then
' s'il n'y pas de plage, on vérifie dans toute la feuille
xlApp.Cells.Find(What:=sWord, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate: cMyAddress.Add ActiveCell.Address
Set rStartCell = ActiveCell
Do
xlApp.Cells.FindNext(After:=ActiveCell).Activate: cMyAddress.Add ActiveCell.Address
Loop While ActiveCell.Address <> xlApp.Range(rStartCell.Address).Address
' on place l'adresse des cellules dans un tableau de données
' il sera facile de savoir après quelles cellules contiennent
' les données recherchées. (où même sélectionner ces cellules)
ReDim sRes(cMyAddress.Count - 1)
For i = 0 To cMyAddress.Count - 1
sRes(i) = cMyAddress.Item(i + 1)
Next i
Else
' s'il y une plage, on vérifie seulement dedans
Set rPlage = Range(vPlage)
' on instancie l'objet (plage) en récupérant sa valeur
ParseRange = Split(CStr(rPlage.Address), ":")
' ici je récupère la dernière cellule de recherche, afin de la sélectionner
' comme ça, le résultat sera chronologique (sinon, la recherche s'effectue
' depuis la cellule sélectionnée)
xlApp.Range(ParseRange(1)).Select
xlApp.Range(vPlage).Find(What:=sWord, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate: cMyAddress.Add ActiveCell.Address
Set rStartCell = ActiveCell
Do
xlApp.Range(vPlage).FindNext(After:=ActiveCell).Activate: cMyAddress.Add xlApp.ActiveCell.Address
Loop While ActiveCell.Address <> xlApp.Range(rStartCell.Address).Address
' on place l'adresse des cellules dans un tableau de données
' il sera facile de savoir après quelles cellules contiennent
' les données recherchées. (où même sélectionner ces cellules)
ReDim sRes(cMyAddress.Count - 2)
For i = 0 To cMyAddress.Count - 2
sRes(i) = cMyAddress.Item(i + 1)
Next i
End If
If bFileNotRunning Then xlBook.Close False: xlApp.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
FindWord = sRes: Set cMyAddress = Nothing: Erase sRes
End Function
Private Sub Exemple_Utilisation()
Dim sResult() As String, sFile As String, l As Integer
sFile = "C:\Documents and settings\Mortalino\Bureau\Nouveau.xls"
sResult = FindWord("bonjour", sFile, "Feuil1", "A1:B50")
' *** autres exemples d'utilisation *** :
'sResult = FindWord("abc", sFile, "Feuil2", Range("A1:B20"))
'sResult = FindWord(UserForm1.ComboBox1.Text, sFile, "Ma Feuille")
For l = 0 To UBound(sResult)
Debug.Print "-" & sResult(l) & "-"
Next l
Erase sResult
End Sub