Reemplezar palabras

Prueba con esta macro que saque en su dia de internet, esta un poco a la
española, pero el codigo esta respetado y funciona, Sirve para
reemplezar palabras o textos en muchos documentos sin tener que abrir
uno a uno, lo unico que tienes que hacer es lo siguiente:

1º Ponerte todos los documentos a los que quieras reemplazar palabra en
una carpeta

2º Copyar y pegar todo este código de macro en Un documento de word
exactamente que este grabada en la plantilla normal.dot (para todos los
documentos)

3ºUna vez guardada, copiada y demás, abres cualquier documento de word,
y ejecutas la macro desde ese archivo abierto, Te pedira la ruta donde
tengas la carpeta de tus documentos de word.(si has abierto un archivo
dentro de esa carpeta te saldra la ruta propia de la carpeta en blanco,
no hay problemas, le das a abrir)

4ªUna vez ejecutada te sale un InputBox para introducir la palabra o
texto que quieras reemplezar, y luego otro InputBox con la palabra nueva
que quieras cambiar.

5º Aceptas todo y tardara un ratillo dependendiendo de los documentos
que se encuentren en esa carpeta. (más o menos a segundo por documento)

Y 6º Para cualquier duda Comentas, a veces me cuesta explicarme un poco, ok?

Public Sub SustituirTextoTodosDocumentos()
'Macro by Doug Robbins - 1st March 2004

Dim PrimerLazo As Boolean
Dim myFile As String
Dim Trayectoria As String
Dim myDoc As Document
Dim rango As Word.Range
Dim EncontrarTexto As String
Dim Replacement As String
' Encontrar la carpeta que contiene los archivos
With Dialogs(wdDialogCopyFile)
If .Display <> 0 Then
Trayectoria = .Directory
Else
MsgBox "Cancelado"
Exit Sub
End If
End With
'Cerrar documentos que esten abiertos
If Documents.Count > 0 Then
Documents.Close Savechanges:=wdPromptToSaveChanges
End If
PrimerLazo = True
If Left(Trayectoria, 1) = Chr(34) Then
Trayectoria = Mid(Trayectoria, 2, Len(Trayectoria) - 2)
End If
myFile = Dir$(Trayectoria & "*.doc")
While myFile <> ""
'Coger texto a reamplazar y reemplazarlo
If PrimerLazo = True Then
EncontrarTexto = InputBox("Escriba el texto que usted quiere reemplazar.", "Batch Replace Anywhere")
If EncontrarTexto = "" Then
MsgBox "Cancelado"
Exit Sub
End If
Tryagain: Replacement = InputBox("Entre el texto nuevo.", "BatchReplaceAnywhere")
If Replacement = "" Then
Response = MsgBox("¿Quiere borrar el texto encontrado?", vbYesNoCancel)
If Response = vbNo Then
GoTo Tryagain
ElseIf Response = vbCancel Then
MsgBox "Cancelado"
Exit Sub
End If
End If
PrimerLazo = False
End If
'Abrir para reemplazar texto a archivos
Set myDoc = Documents.Open(Trayectoria & myFile)
HacerlaValida
For Each rango In ActiveDocument.StoryRanges
Do
BuscarYReemplazar rango, EncontrarTexto, Replacement
Set rango = rango.NextStoryRange
Loop Until rango Is Nothing
Next
'Cerrar Archivos Guardando los cambios
myDoc.Close Savechanges:=wdSaveChanges
myFile = Dir$()
Wend
End Sub
Public Sub BuscarYReemplazar(ByVal rango As Word.Range, _
ByVal strSearch As String, _
ByVal strReplace As String)
'rutina provista by Peter Hewett
Do Until (rango Is Nothing)
With rango.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.Replacement.Text = strReplace
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
End With
Set rango = rango.NextStoryRange
Loop
End Sub
Public Sub HacerlaValida()

Dim lngJunk As Long
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType


End Sub

-

¡Un SAludo!
Mónica
www.fermu.com
www.zorval.es