Macro for replacing EXCEL data into WORD

[rs.blackcat]

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.

[macropod]

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.

[rs.blackcat]

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

[macropod]

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.

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.

[Robxk]

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

[Robxk]

Hi

Managed to get this working.

.Replacement.Font.Bold = True


Regards

Robert

[Rolsen]

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:


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.

[Rolsen]

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

[macropod]

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

[Khanonline]

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

[macropod]

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.

[Khanonline]

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.

[macropod]

You could change:

.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:

.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.

[HansZa]

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

[macropod]

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.

[CRay]

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.

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

[macropod]

Try:

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

[tylerhahn3]

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

[tbrown]

Thanks Marcopod!

[SamT]

Paul,

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

[macropod]

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

[gmaxey]

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.



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