Macro for replacing EXCEL data into WORD

Hello,

I'm completely new using VBA, macros and programming as a whole. I'm trying to make a macro that replaces some predefined words from a *.doc document with values (in this case words) of a cell from an excel-sheet.

My aim is to have an automation for an excel-sheet with the data as shown below. And a form/application/some ms-word document that needs to be fill out.

FIST_NAME MIDDLE_NAME LAST_NAME D.O.B

The macro will just replace the values entered in the excel-sheet to the *.doc document.

Can someone please help me with this? Thank you.

Depending on what you're trying to achieve, you may not need a macro at all.

If, for example, you're trying to produce multiple letters or a report using the Excel data, a mailmerge in Word, with the Excel workbook as the data source, might meet your needs.

Alternatively, if you just want the Word document to reflect whatever's in a particular set of Excel cells at the time, you could use LINK fields in the Word document.

What you've described is really better suited to situations where you might have a Find/Replace list in Excel that you want to process in one or more documents.

Thank you for the reply. You are absolutely right. How can I do a find/replace list in excel from a word file?

The following Word macro allows you to use an Excel Workbook to hold Find/Replace strings as the source for a large-scale Find/Replace operation. In this example, the macro finds the strings referred to in column A and replaces them with the strings referred to in column B. The user has the option to skip particular found strings, or to cancel the process altogether. Comments in the code show how to make the processing automatic (ie no user intervention). The bulk of the code (around 80%) is for managing the Excel session.

Code:

---

Sub BulkFindReplace()
Application.ScreenUpdating = True
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim bStrt As Boolean, iDataRow As Long, bFound As Boolean
Dim xlFList As String, xlRList As String, i As Long, Rslt
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\Workbook Name.xls"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
' Test whether Excel is already running.
On Error Resume Next
bStrt = False ' Flag to record if we start Excel, so we can close it later.
Set xlApp = GetObject(, "Excel.Application")
'Start Excel if it isn't running
If xlApp Is Nothing Then
  Set xlApp = CreateObject("Excel.Application")
  If xlApp Is Nothing Then
    MsgBox "Can't start Excel.", vbExclamation
    Exit Sub
  End If
  ' Record that we've started Excel.
  bStrt = True
End If
On Error GoTo 0
'Check if the workbook is open.
bFound = False
With xlApp
  'Hide our Excel session
  If bStrt = True Then .Visible = False
  For Each xlWkBk In .Workbooks
    If xlWkBk.FullName = StrWkBkNm Then ' It's open
      Set xlWkBk = xlWkBk
      bFound = True
      Exit For
    End If
  Next
  ' If not open by the current user.
  If bFound = False Then
  ' Check if another user has it open.
  If IsFileLocked(StrWkBkNm) = True Then
  ' Report and exit if true
  MsgBox "The Excel workbook is in use." & vbCr & "Please try again later.", vbExclamation, "File in use"
  If bStrt = True Then .Quit
    Exit Sub
  End If
  ' The file is available, so open it.
  Set xlWkBk = .Workbooks.Open(Filename:=StrWkBkNm)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    If bStrt = True Then .Quit
    Exit Sub
  End If
End If
' Process the workbook.
With xlWkBk.Worksheets(StrWkSht)
  ' Find the last-used row in column A.
  ' Add 1 to get the next row for data-entry.
  iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
  ' Output the captured data.
  For i = 1 To iDataRow
    ' 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
If bFound = False Then xlWkBk.Close False
If bStrt = True Then .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Process each word from the F/R List
For i = 1 To UBound(Split(xlFList, "|"))
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .MatchWholeWord = True
    .MatchCase = True
    .Wrap = wdFindStop
    .Text = Split(xlFList, "|")(i)
    .Execute
    'To automatically change the found text:
    '? comment-out/delete the previous line and the Do While Loop
    '? uncomment the next two lines
    '.Replacement.Text = Split(xlRList, "|")(i)
    '.Execute Replace:=wdReplaceAll
  End With
  'Ask the user whether to change the found text
  Do While .Find.Found
    .Duplicate.Select
    Rslt = MsgBox("Replace this instance of:" & vbCr & _
      Split(xlFList, "|")(i) & vbCr & "with:" & vbCr & _
      Split(xlRList, "|")(i), vbYesNoCancel)
    If Rslt = vbCancel Then Exit Sub
    If Rslt = vbYes Then .Text = Split(xlRList, "|")(i)
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Next
Application.ScreenUpdating = True
End Sub
'
Function IsFileLocked(strFileName As String) As Boolean
On Error Resume Next
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
IsFileLocked = Err.Number
Err.Clear
End Function

---

You will, of course, need to supply your own workbook name and, perhaps, part or all of its path.

Hi Macropod

Excellent script it works exactly as I require (well nearly)

Can you tell me how to change the replaced text to bold.

I needed it highlighting but have solved that by changing the following
'.Replacement.ClearFormatting
.Replacement.Highlight = True

I have tried the following to change the font to Bold

.Replacement.Font = Bold
.Replacement.Font = BoldBi
.Replacement.Style = Bold

Clearly I am not hitting the mark and know this is very simple. Can you please help with this.

Thanks

Hi

Managed to get this working.

.Replacement.Font.Bold = True


Regards

Robert

Quote:

---

Originally Posted by Robxk

Hi

Managed to get this working.

.Replacement.Font.Bold = True


Regards

Robert

---

Hi.

For some reason I can't get this to work?
My code looks like this:

Code:

---

With ActiveDocument.Range
            With .Find
                .ClearFormatting
                .Replacement.Font.Bold = True
                .MatchWholeWord = True
                .MatchCase = True
                .Wrap = wdFindStop
                .Text = Split(xlFList, "|")(i)
                .Execute
                'To automatically change the found text:
                '• comment-out/delete the previous line and the Do While Loop
                '• uncomment the next two lines
                '.Replacement.Text = Split(xlRList, "|")(i)
                '.Execute Replace:=wdReplaceAll
            End With

---

I'm new to all this VBA coding so there is a big chance I have put the section the wrong place.

Best Regards Rasmus.

I changed the .execute to automatic replacement and now it works with bold replacement? Is there a simple explaination for this?

I suggest you check what's in the document - there's nothing in the code to apply any particular formatting.

Hello

Its a brilliant effort and I need some alteration in Code.
Some where if Half of the value found in code, it also replace part of the that.
Can we replace if Whole caption of cell (Ms Excel) is matched with whole caption of (Table)cell in ms Word? Can anybody help here?
Thanks

Khanonline: I have no idea what you're on about, re: "Half of the value found in code" or "Whole caption of cell". Also, instead of resurrecting old threads for what is evidently a new issue, you should start your own thread - explaining precisely what you want to achieve.

It was a bit urgent to solve the issue. Although it didn't resolved yet. Anyways Thanks for reply.

Paul: One thing I would like to quote here; the reason behind the resurrecting is my issue is same as this was but In word File it replaces the half data of the cell if matched in excel;
what I required was if value of whole cell of Table (in Word File) is matched then it should replace the excel value and if half or any portion of cell in Table matched then it should left the cell as it is.

Although it is challenge for me and indirectly was for you guys as well.

Thanks for your patience and apologies for inconvenience.

You could change:

Code:

---

      .Execute
      'To automatically change the found text:
      '• comment-out/delete the previous line and the Do While Loop
      '• uncomment the next two lines
      '.Replacement.Text = Split(xlRList, "|")(i)
      '.Execute Replace:=wdReplaceAll
    End With
    'Ask the user whether to change the found text
    Do While .Find.Found
      .Duplicate.Select
      Rslt = MsgBox("Replace this instance of:" & vbCr & _
        Split(xlFList, "|")(i) & vbCr & "with:" & vbCr & _
        Split(xlRList, "|")(i), vbYesNoCancel)
      If Rslt = vbCancel Then Exit Sub
      If Rslt = vbYes Then .Text = Split(xlRList, "|")(i)
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop

---

to:

Code:

---

      .Execute
    End With
    Do While .Find.Found
      With .Duplicate
        If .Information(wdWithInTable) = True Then
          If Len(.Cells(1).Range.Text) = Len(Split(xlRList, "|")(i)) + 2 Then
            .Text = Split(xlRList, "|")(i)
          End If
        End If
      End With
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop

---

For future reference, please start a new thread when starting a new topic, with links to any existing threads you think may be relevant.

Dear user Macropod / Paul,

I just wanted to say thanks for this extremely helpful bit of VBA code - I' m using it to insert ressource identifiers to scientific manuscripts, a rather repetitive task that is a lot faster (and less boring) with your macro.

Are there any legal /copyright restrictions in sharing this code? I think others in the field might like it too. Who should it be credited to (Paul Edstein/ Macropod?).

Cheers,

Hans Zauner

Code posted on these forums is free to use. If you're going to redistribute it, acknowledgement of the source would be appreciated (e.g. a comment in the code linking to where you found it). Regardless, you should avoid giving the impression it's your own code.

Hi,

99% of the time I find answers to all my code questions by reading through many forums, hence the reason I've never posted here before. However, this time, I'm pretty well stumped. :banghead: I know enough (with a little help from google) to follow macropod's code above (and I will agree it is genius) however, I don't know enough to accurately fit it to my application. My goal is to simply have several text replacements in an existing word document template, using an existing worksheet. I have a range of text in column (A) I would like to have replaced with text in column (B). I am able to open both documents and change the first text replacement, but then it stops. Now I believe determined I need to write a For Loop to get this accomplished (just like in macropod's code above) difference is my data does not vary in array size. It will always be (A1:A8) to be replaced by (B1:B8). Any help is greatly appreciated. Below is where I'm at right now.

Code:

---

Dim oWord As Word.Application    Dim RngF As String
    Dim RngR As String
 
    RngF = Range("A1:A8")
    RngR = Range("B1:B8")
   
    Application.ScreenUpdating = False


    'Set application
    Set oWord = CreateObject("Word.Application")
     
    oWord.Documents.Open (C:\\Path\Document.docx")
   
    oWord.Visible = True
   
    'Loop through find and replace
    For i = 1 To (RngF)
        With ActiveDocument.Range
            With .Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .MatchWholeWord = True
                .MatchCase = True
                .Wrap = wdFindContinue
                .Text = (RngS) (i)
                .Replacement.Text = (RngR) (i)
                .Execute Replace:=wdReplaceAll
            End With
        End With
    Next
   
    Application.ScreenUpdating = True

---

Try:

Code:

---

Sub Demo()
Dim oWord As Word.Application, i As Long
Application.ScreenUpdating = False
Set oWord = CreateObject("Word.Application")
With oWord
  .Documents.Open ("C:\Path\Document.docx")
  With .ActiveDocument.Range.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .MatchWholeWord = True
    .MatchCase = True
    .Wrap = wdFindContinue
    For i = 1 To 8
      .Text = ActiveSheet.Range("A" & i)
      .Replacement.Text = ActiveSheet.Range("B" & i)
      .Execute Replace:=wdReplaceAll
    Next
  End With
  .Visible = True
End With
Application.ScreenUpdating = True
End Sub

---

Hi Macropod:

Firstly, thank you very much for your code here - and for commenting it so well, and writing it with such clear syntax.

Thanks for your help!

Tyler

Thanks Marcopod!

Paul,

This thread has been reopened every year for six years. Think we should Sticky it?

I'm not inclined to go creating 'sticky' threads for individual topics that get resurrected periodically. A knowledgebase article might be more appropriate.

Paul,

I agree! I don't like Sticky posts either (of any type). This is another good one for ADODB. I've not tried very hard to find a solution, because for my own use it has not been a problem. However if you go digging into this topic you might be compelled to conjure up a method to prevent trying to connect with a database that is not accessible because it is in use. You will see the potential problem if you have your Excel file open with the cursor in the formula bar and ignore the note to cancel.

Code:

---

Option Explicit
Sub BulkFindReplace()
Dim arrList
Dim lngIndex As Long
Dim strWBName As String
Dim oRng As Range
  'Get the list of terms to find and replace.
  strWBName = ThisDocument.Path & "\Word List.xlsx" 'Change to suit path and file name.
  If Dir(strWBName) = "" Then
    MsgBox "Cannot find the designated workbook: " & strWBName, vbExclamation
    Exit Sub
  End If
  If IsFileLocked(strWBName) Then
    If MsgBox("The data file is open in Excel." & vbCr + vbCr _
        & "While the Excel file can be open while accessing data, " _
        & "the underlying database cannot be in transition " _
        & "e.g., the cursor in the formula bar." & vbCr + vbCr _
        & "When in transistion a connection to the data cannot be made." & vbCr + vbCr _
        & "Recommend you cancel, then save and close the Excel file and try again." & vbCr + vbCr _
        & "Do you want to cancel?", vbQuestion + vbYesNo, "IMPORTANT USER NOTIFICATION") = vbYes Then
        Exit Sub
    End If
  End If
  arrList = fcnExcelDataToArray(strWBName)
  Application.ScreenUpdating = True
  If IsArray(arrList) Then
  For lngIndex = 0 To UBound(arrList, 2)
    Set oRng = ActiveDocument.Range
    With oRng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWholeWord = True
      .MatchCase = True
      .Wrap = wdFindStop
      .Text = arrList(0, lngIndex)
      'For automatic replacement unstet the following two lines and stet out all between While and Wend _
      that follows
      '.Replacement.Text = arrList(1, lngIndex)
      '.Execute Replace:=wdReplaceAll
      'For user prompt and manual replacement, stet out previous two lines and use:
      While .Execute
        With oRng
          .Duplicate.Select
          Select Case MsgBox("Replace this instance of: " & arrList(0, lngIndex) _
              & vbCr & "with: " & arrList(1, lngIndex), vbYesNoCancel)
            Case vbYes: .Text = arrList(1, lngIndex)
            Case vbCancel: Exit Sub
          End Select
          .Collapse wdCollapseEnd
        End With
      Wend
    End With
  Next
  Else
    MsgBox "A connection was not available to the Excel file."
  End If
  Application.ScreenUpdating = True
lbl_Exit:
  Exit Sub
End Sub
 
Private Function fcnExcelDataToArray(strWorkbook As String, _
                                    Optional strRange As String = "Sheet1", _
                                    Optional bIsSheet As Boolean = True, _
                                    Optional bHeaderRow As Boolean = True) As Variant
'Default parameters include "Sheet1" as the named sheet, range of the full named sheet and a header row is used.
Dim oRS As Object, oConn As Object
Dim lngRows As Long
Dim strHeaderYES_NO As String
  strHeaderYES_NO = "YES"
  If Not bHeaderRow Then strHeaderYES_NO = "NO"
  If bIsSheet Then strRange = strRange & "$]" Else strRange = strRange & "]"
  Set oConn = CreateObject("ADODB.Connection")
  oConn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & strWorkbook & ";" & _
        "Extended Properties=""Excel 12.0 Xml;HDR=" & strHeaderYES_NO & """;"
  If oConn.State = 0 Then
    oConn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.15.0;" & _
        "Data Source=" & strWorkbook & ";" & _
        "Extended Properties=""Excel 12.0 Xml;HDR=" & strHeaderYES_NO & """;"
  End If
  If oConn.State = 1 Then
    Set oRS = CreateObject("ADODB.Recordset")
    oRS.Open "SELECT * FROM [" & strRange, oConn, 2, 1
    With oRS
      .MoveLast
      lngRows = .RecordCount
      .MoveFirst
    End With
    fcnExcelDataToArray = oRS.GetRows(lngRows)
  Else
    fcnExcelDataToArray = "~~NO CONNECTION AVAILABLE~~"
  End If
lbl_Exit:
  If oConn.State = 1 Then
    oConn.Close
    If oRS.State = 1 Then oRS.Close
    Set oRS = Nothing
  End If
  Set oConn = Nothing
  Exit Function
End Function
Function IsFileLocked(strFileName As String) As Boolean
    On Error Resume Next
    Open strFileName For Binary Access Read Write Lock Read Write As #1
    Close #1
    IsFileLocked = Err.Number
    Err.Clear
End Function

---