Excel - MACRO EN EXCEL PARA BUSCAR CADENA DE TEXTO EN WORD

Sub Busca_e_Informa()

[A:A].ClearContents

With Application.FileSearch

.NewSearch

.LookIn = "C:Aaa"

.FileName = "A*; P*"

.SearchSubFolders = False

.TextOrProperty = "Turbocompresor"

.FileType = msoFileTypeWordDocuments

If .Execute() > 0 Then

For i = 1 To .FoundFiles.Count

Range("A" & i) = .FoundFiles(i)

Next i

Else

MsgBox "No se encontró ningún archivo."

End If

End With

End Sub

Option Explicit

'//By JuanC - Ene. 2008

Sub SearchWordsInDoc()

Dim wDoc As Object

Dim wApp As Object

Dim fs As Variant

Dim lCount&, i&, sText$

Dim sFullName$, lOff&

Set fs = Application.FileSearch

Set wApp = GetWord

If wApp Is Nothing Then GoTo Fin

Application.ScreenUpdating = False

sText = "julio" '//Texto a buscar

Set fs = Application.FileSearch

With fs

     .LookIn = "c:windowsescritorio" '//Carpeta de búsqueda

     .SearchSubFolders = True

     .Filename = "*.doc"

     If .Execute(SortBy:=msoSortByLastModified, SortOrder:=msoSortOrderAscending, AlwaysAccurate:=True) > 0 Then

        lCount = .FoundFiles.Count

        For i = 1 To lCount

            sFullName = .FoundFiles(i)

            Set wDoc = wApp.Documents.Open(sFullName)

            If Not wDoc Is Nothing Then

               If FindText(wDoc, sText) Then

                  [A1].Offset(lOff).Hyperlinks.Add Anchor:=[A1].Offset(lOff), Address:=wDoc.FullName

                  lOff = lOff + 1

               End If

               wDoc.Close False

            End If

        Next

     End If

End With

wApp.Quit

Fin:

Application.ScreenUpdating = True

Set fs = Nothing

Set wApp = Nothing

Set wDoc = Nothing

End Sub

Private Function GetWord() As Object

On Error GoTo Create

Set GetWord = GetObject(, "Word.Application")

Exit Function

Create:

Set GetWord = CreateObject("Word.Application")

End Function

Private Function FindText(ByVal Doc As Object, ByVal sText As String) As Boolean

On Error Resume Next

With Doc.Content.Find

     .ClearFormatting

     If .Execute(FindText:=sText) Then

        FindText = True

     Else

          FindText = False

     End If

End With

End Function