0

Tengo hecha esta macro para buscar y reemplazar palabras desde un archivo específico, que en este caso es un documento de Word.

Mi consulta es:

¿Cómo hago para que en vez de un documento de word, tome el contenido de una lista de excel?

Éste es el código:

Sub ListaDeBalanceEspPort01()
Dim oChanges As Document, oDoc As Document
Dim oTable As Table
Dim oRng As Range
Dim rFindText As Range, rReplacement As Range
Dim i As Long
Dim sFname As String
sFname = "C:\Users\tini\Documents\SLAP\ESaPTinc.doc"
Set oDoc = ActiveDocument
Set oChanges = Documents.Open(FileName:=sFname, Visible:=False)
Set oTable = oChanges.Tables(1)
For i = 1 To oTable.Rows.Count
    Set oRng = oDoc.Range
    Set rFindText = oTable.Cell(i, 1).Range
    rFindText.End = rFindText.End - 1
    Set rReplacement = oTable.Cell(i, 2).Range
    rReplacement.End = rReplacement.End - 1
    With oRng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            Do While .Execute(findText:=rFindText, _
                MatchWholeWord:=False, _
                MatchWildcards:=False, _
                Forward:=True, _
                Wrap:=wdFindContinue) = True
                oRng.Text = rReplacement
            Loop
    End With
Next i
oChanges.Close wdDoNotSaveChanges
End Sub

Gracias,

Sol

2 respuestas 2

1

Yo tengo un método. Lo primero es incluir la referencia a la librería de Excel: introducir la descripción de la imagen aquí introducir la descripción de la imagen aquí

Una vez hecho esto, utiliza este código que he compilado a partir del tuyo:

Sub ListaDeBalanceEspPort01()
    Dim oChanges As Workbook
    Dim oDoc As Document
    Dim oRng As Range
    Dim rFindText As String
    Dim rReplacement As String
    Dim i As Long
    Dim sFname As String
    sFname = "C:\Users\tini\Documents\SLAP\ESaPTinc.xlsx"
    Set oDoc = ActiveDocument
    Set oChanges = Workbooks.Open(sFname, True, True)
    oChanges.Sheets(1).Range("A1").Select
    For i = 1 To oChanges.Worksheets("sheet1").Range("A1:A" & Cells(Rows.Count, "B").End(xlUp).Row).Rows.Count
        Set oRng = oDoc.Range
        rFindText = oChanges.Sheets(1).Range("A" & i).Value
        rReplacement = oChanges.Sheets(1).Range("B" & i).Value
        With oRng.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                Do While .Execute(findText:=rFindText, _
                    MatchWholeWord:=False, _
                    MatchWildcards:=False, _
                    Forward:=True, _
                    Wrap:=wdFindContinue) = True
                    oRng.Text = rReplacement
                Loop
        End With
    Next i
    oChanges.Close False
End Sub

Fíjate en que ahora el documento que tiene la lista es un Excel ;)

0

El codigo de @Joracosu funciona bien, el problema es el excel de origen. En nuestro caso , en la traduccion existian valores iguales y el script se rompia. La solucion ha sido comprobar el valor del excel antes de hacer nada

If (rFindText <> rReplacement) Then

Pego todo el codigo para q este en su totalidad

Sub Remplazar()

    Dim oChanges As Workbook
    Dim oDoc As Document
    Dim oRng As Range
    Dim rFindText As String
    Dim rReplacement As String
    Dim i As Long
    Dim sFname As String
    sFname = "C:\Users\USUARIO\Desktop\traduccion.xlsx"
    Set oDoc = ActiveDocument
    Set oChanges = Workbooks.Open(sFname, True, True)
    oChanges.Sheets(1).Range("A1").Select
    For i = 1 To oChanges.Worksheets("Hoja1").Range("A1:A" & Cells(Rows.Count, "B").End(xlUp).Row).Rows.Count
        Set oRng = oDoc.Range
        rFindText = oChanges.Sheets(1).Range("A" & i).Value
        rReplacement = oChanges.Sheets(1).Range("B" & i).Value
        If (rFindText <> rReplacement) Then
            With oRng.Find
                    .ClearFormatting
                    .Replacement.ClearFormatting
                    Do While .Execute(findText:=rFindText, _
                        MatchWholeWord:=False, _
                        MatchWildcards:=False, _
                        Forward:=True, _
                        Wrap:=wdFindContinue) = True
                        oRng.Text = rReplacement
                    Loop
            End With
        End If
    Next i
    oChanges.Close False
End Sub

¿No es la respuesta que buscas? Examina otras preguntas con la etiqueta o formula tu propia pregunta.