Find & Replace from Excel to Word

[xiaoying]

I want to be able to find the second result of the word I am searching for and replace it with the value from Excel. However, I am clueless on how to do it. Below is part of my codes and I would really appreciate your help

         With .ActiveDocument.Content.Find
            .ClearFormatting
            .Replacement.ClearFormatting

            .Text = "Suntec City Mall"
            .Replacement.Text = ws.Range("N" & currentRow).Value

            .Forward = True
            .Wrap = 1               'wdFindContinue (WdFindWrap Enumeration)
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False

            .Execute Replace:=1     'wdReplaceOne (WdReplace Enumeration)
        End With

 

[NdNoviceHlp]

If Wdapp was your Word object application which has opened some Word document, this seems like it would work...

Dim Last As Integer, Cnt As Integer, Flag As Boolean
Cnt = 1
Last = wdapp.ActiveDocument.Paragraphs.Count
Flag = False
'loop paragraphs
Do While Cnt < Last
'don't search blank paras
If wdapp.ActiveDocument.Paragraphs(Cnt).Range.Text <> Chr(13) Then
With wdapp.ActiveDocument.Paragraphs(Cnt).Range.Find
.Text = "Suntec City Mall"
.Forward = True
.Execute
'replace 2nd occurrence
If .found = True Then
If Flag Then
.Replacement.Text = ws.Range("N" & currentRow).Value
Exit Sub
End If
Else
Flag = True
End If
End With
End If 'blank paras
Cnt = Cnt + 1
Loop

HTH. Dave

 

[xiaoying]

Hi Dave, thank you so much for your help. But your code is hard to understand and implement inside my current codes. Below is my declarations and variables if it helps.

Dim ws As Worksheet, msWord As Object
    Dim currentRow As Long
    Dim rowCount As Long
    Dim lastRow As Long
    Dim filename As String
    Dim Path1 As String
    Dim premise As String
    Dim myMRange As Range
    Dim finish As Integer
  
    Path1 = "C:\Edited Letters"
    Set ws = ActiveSheet
    Set msWord = CreateObject("Word.Application")
    lastRow = ws.Cells(Rows.Count, 1).End(xlUp).row
  
    For currentRow = 2 To lastRow
    If Not ws.Rows(currentRow).Hidden Then
    filename = ws.Range("B" & currentRow).Value
    Set myMRange = ws.Range("M" & currentRow)
    premise = ws.Range("N" & currentRow).Value
  
    With msWord
        .Visible = True
        .Documents.Open "C:\2018 KPL - STC draft report.docx"
        .Activate

If Wdapp was your Word object application which has opened some Word document, this seems like it would work...

Dim Last As Integer, Cnt As Integer, Flag As Boolean
Cnt = 1
Last = wdapp.ActiveDocument.Paragraphs.Count
Flag = False
'loop paragraphs
Do While Cnt < Last
'don't search blank paras
If wdapp.ActiveDocument.Paragraphs(Cnt).Range.Text <> Chr(13) Then
With wdapp.ActiveDocument.Paragraphs(Cnt).Range.Find
.Text = "Suntec City Mall"
.Forward = True
.Execute
'replace 2nd occurrence
If .found = True Then
If Flag Then
.Replacement.Text = ws.Range("N" & currentRow).Value
Exit Sub
End If
Else
Flag = True
End If
End With
End If 'blank paras
Cnt = Cnt + 1
Loop

HTH. Dave

 

[xiaoying]

This is the bottom part of my code.

msWord.ActiveDocument.SaveAs filename:=Path1 & "/" & filename & Space(1) & premise & " - draft report" & ".docx"
        msWord.ActiveDocument.Close
        rowCount = rowCount + 1
    End With
    End If
    Next currentRow
    msWord.Quit
    finish = MsgBox("Automation of letter is done", vbOKOnly + vbInformation + vbDefaultButton1, "Generate Letter")
End Sub

 

[NdNoviceHlp]

Seems like your doing a whole bunch of files at once. U can trial this. HTH. Dave

Option Explicit
Sub test()
Dim ws As Worksheet, msWord As Object
Dim currentRow As Long
Dim rowCount As Long
Dim lastRow As Long
Dim filename As String
Dim Path1 As String
Dim premise As String
Dim myMRange As Range
Dim finish As Integer, cnt As Integer, Last As Integer, Flag As Boolean
Path1 = "C:\Edited Letters"
Set ws = ActiveSheet
Set msWord = CreateObject("Word.Application")
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

For currentRow = 2 To lastRow
If Not ws.Rows(currentRow).Hidden Then
filename = ws.Range("B" & currentRow).Value
'Set myMRange = ws.Range("M" & currentRow)
premise = CStr(ws.Range("N" & currentRow).Value)

With msWord
.Visible = False 'True
.Documents.Open filename '"C:\2018 KPL - STC draft report.docx"
'.Activate
cnt = 1
Last = msWord.ActiveDocument.Paragraphs.Count
Flag = False
'loop paragraphs
Do While cnt < Last
'don't search blank paras
If msWord.ActiveDocument.Paragraphs(cnt).Range.Text <> Chr(13) Then
With msWord.ActiveDocument.Paragraphs(cnt).Range.Find
.Text = "Suntec City Mall"
.Forward = True
.Execute
'replace 2nd occurrence
If .found = True Then
If Flag Then
.Replacement.Text = premise 'ws.Range("N" & currentRow).Value
Exit Sub
End If
Else
Flag = True
End If
End With
End If 'blank paras
cnt = cnt + 1
Loop

msWord.ActiveDocument.SaveAs filename:=Path1 & "\" & filename & "_" & premise & " - draft report" & ".docx"
msWord.ActiveDocument.Close
rowCount = rowCount + 1
End With
End If
Next currentRow

msWord.Quit
Set msWord = Nothing
finish = MsgBox("Automation of letter is done", vbOKOnly + vbInformation + vbDefaultButton1, "Generate Letter")
End Sub

 

[xiaoying]

Seems like your doing a whole bunch of files at once. U can trial this. HTH. Dave

Option Explicit
Sub test()
Dim ws As Worksheet, msWord As Object
Dim currentRow As Long
Dim rowCount As Long
Dim lastRow As Long
Dim filename As String
Dim Path1 As String
Dim premise As String
Dim myMRange As Range
Dim finish As Integer, cnt As Integer, Last As Integer, Flag As Boolean
Path1 = "C:\Edited Letters"
Set ws = ActiveSheet
Set msWord = CreateObject("Word.Application")
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

For currentRow = 2 To lastRow
If Not ws.Rows(currentRow).Hidden Then
filename = ws.Range("B" & currentRow).Value
'Set myMRange = ws.Range("M" & currentRow)
premise = CStr(ws.Range("N" & currentRow).Value)

With msWord
.Visible = False 'True
.Documents.Open filename '"C:\2018 KPL - STC draft report.docx"
'.Activate
cnt = 1
Last = msWord.ActiveDocument.Paragraphs.Count
Flag = False
'loop paragraphs
Do While cnt < Last
'don't search blank paras
If msWord.ActiveDocument.Paragraphs(cnt).Range.Text <> Chr(13) Then
With msWord.ActiveDocument.Paragraphs(cnt).Range.Find
.Text = "Suntec City Mall"
.Forward = True
.Execute
'replace 2nd occurrence
If .found = True Then
If Flag Then
.Replacement.Text = premise 'ws.Range("N" & currentRow).Value
Exit Sub
End If
Else
Flag = True
End If
End With
End If 'blank paras
cnt = cnt + 1
Loop

msWord.ActiveDocument.SaveAs filename:=Path1 & "\" & filename & "_" & premise & " - draft report" & ".docx"
msWord.ActiveDocument.Close
rowCount = rowCount + 1
End With
End If
Next currentRow

msWord.Quit
Set msWord = Nothing
finish = MsgBox("Automation of letter is done", vbOKOnly + vbInformation + vbDefaultButton1, "Generate Letter")
End Sub

Thank you Dave

 

[NdNoviceHlp]

You are welcome. I'll assume the happy face is project complete. Dave

 

[Macropod]

Try the following - it should be significantly faster, especially with large documents where the text to find is located towards the end of the document:

Sub BulkFindReplace()
'Note: The code requires a VBA reference to the Word Object Library.
'See under Tools|References in the VBE.
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim xlFList As String, xlRList As String, i As Long, j As Long
'Get the folder to process
strFolder = GetFolder
If strFolder = "" Then GoTo ErrExit
With ActiveSheet
  ' Capture the F/R data.
  For i = 1 To .Cells(.Rows.Count, 1).End(-4162).Row
    ' Skip over empty fields to preserve the underlying cell contents.
    If Trim(.Range("A" & i)) <> vbNullString Then
      xlFList = xlFList & "|" & Trim(.Range("A" & i))
      xlRList = xlRList & "|" & Trim(.Range("B" & i))
    End If
  Next
End With
'Exit if there are no data
If xlFList = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
'Process each document in the folder
Do While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    'Process each word from the F/R List
    With wdDoc
      For i = 1 To UBound(Split(xlFList, "|"))
        j = 0
        With .Range
          With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .MatchWholeWord = True
            .MatchCase = True
            .Wrap = wdFindContinue
            .Text = Split(xlFList, "|")(i)
            .Replacement.Text = ""
            .Execute
          End With
          Do While .Find.Found = True
            j = j + 1
            If j = 2 Then
              .Text = Split(xlRList, "|")(i)
              Exit Do
            End If
          Loop
        End With
      Next
      'Close the document
      .Close SaveChanges:=True
    End With
  End If
  'Get the next document
  strFile = Dir()
Loop
ErrExit:
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

 

[xiaoying]

This thread is close.