Visual Basic para Aplicaciones - Editar documentos WORD desde Macro en Excel

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:\windows\escritorio\" '//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, TextToDisplay:=Mid(sFullName, InStrRev(sFullName, "\") + 1)

                  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