Quote:
Originally Posted by Jen75
The content does differ in all of the pages of the Word document. Each page is unique to a single person.
|
In that case, it would have been preferable to have the variable content in the data source also.
However, since you well and truly passed that point, try the following macro:
Code:
Sub Demo()
Application.ScreenUpdating = False
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim iDataRow As Long, xlFndList As String, xlRepList As String, i As Long
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\Employees.xlsx"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
Exit Sub
End If
On Error Resume Next
'Start Excel
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't start Excel.", vbExclamation
Exit Sub
End If
On Error GoTo 0
With xlApp
'Hide our Excel session
.Visible = False
' The file is available, so open it.
Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMru:=False)
If xlWkBk Is Nothing Then
MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
.Quit
Exit Sub
End If
' Process the workbook.
With xlWkBk
'Ensure the worksheet exists
If SheetExists(xlWkBk, StrWkSht) = True Then
With .Worksheets(StrWkSht)
' Find the last-used row in column A.
iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
' Capture the F/R data.
For i = 1 To iDataRow
' Skip over empty fields to preserve the underlying cell contents.
If Trim(.Range("A" & i)) <> vbNullString Then
xlFndList = xlFndList & "|" & Trim(.Range("A" & i))
xlRepList = xlRepList & "|" & Trim(.Range("B" & i))
End If
Next
End With
Else
MsgBox "Cannot find the designated worksheet: " & StrWkSht, vbExclamation
End If
.Close False
End With
.Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Exit if there are no data
If xlFndList = "" Then Exit Sub
With ActiveDocument.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindContinue
.MatchWholeWord = True
.Text = "^w^p"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
'Process each string from the List
For i = 1 To UBound(Split(xlFndList, "|"))
.Text = Split(xlFndList, "|")(i) & vbCr & "ID Field:"
.Replacement.Text = "^& " & Split(xlRepList, "|")(i)
.Execute Replace:=wdReplaceAll
Next
End With
Application.ScreenUpdating = True
End Sub
Function SheetExists(xlWkBk As Object, SheetName As String) As Boolean
Dim i As Long: SheetExists = False
For i = 1 To xlWkBk.Sheets.Count
If xlWkBk.Sheets(i).Name = SheetName Then
SheetExists = True: Exit For
End If
Next
End Function
As coded, the macro assumes the:
• data are in a workbook named 'Employees.xlsx' in your documents folder;
• data are in a worksheet named 'Sheet1';
• employee names in the document are found in column A of the worksheet; and
• employee IDs to be used in the document are found in column B of the worksheet.
You can edit the code to match whatever your actual scenario is.
I note that your sample document is inconsistent regarding the presence of a space after 'ID Field:'. The macro has been coded to work around that by eliminating any white-space before paragraph breaks, then reinserting a space before the ID.