Macro to find and replace words in Word from an Excel list

Question

Macro to find and replace words in Word from an Excel list

Navigation

#1 by (1 votes)
#2 by (0 votes)

0

I have made this macro to search and replace words from a specific file, which in this case is a Word document.

My query is:

How do I make the content of an excel list instead of a word document?

This is the code:

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

Thank you,

Sun

vba excel

asked by Sol Lq 18.01.2017 в 16:14

source

2 answers

Return a promise that contains an array with data from other promises Problems ajax jquery

score 1 · Answer 1

I have a method. The first thing is to include the reference to the Excel library:

Once this is done, use this code that I have compiled from yours:

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

Notice that now the document that has the list is an Excel;)

score 0 · Answer 2

The code of @Joracosu works well, the problem is the excel of origin. In our case, in the translation there were equal values and the script was broken. The solution has been to check the value of the excel before doing anything

If (rFindText <> rReplacement) Then

I paste all the code for this in its entirety

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