VBA Excel Automatic Template Selection - excel

I am writing a VBA script that I want to do smarter mail merge functions with.
Basically, I have 3 word templates that are formatted differently with replacement tags in different places. We'll call these templates 1-3.
I have a table where each row has the necessary replacement data as strings, with a max of 6 strings per row. To the left of this table, in column B, I have the number of strings in the table listed, and based on this number I want it to choose the correct template. I think I may have the LeftCell dim configured incorrectly, or my code is choosing a template correctly the first time, but applying it to all the other rows. If I run the script it always seems to choose the first template.
Sub CreateWordDocuments()
Dim CustRow, CustCol, LastRow, LeftCell, TemplRow As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim WordDoc, WordApp As Object
Dim WordContent As Word.Range
With Sheet1
If .Range("B3").Value = Empty Then
MsgBox "Please select a template from the dropdown list"
.Range("G3").Select
Exit Sub
End If
TemplRow = .Range("B3").Value 'Set Template Row
TemplName = .Range("G3").Value 'Set Template Name
DocLoc = Sheet2.Range("F" & TemplRow).Value 'Word Doc Filename
'Open Word Template
On Error Resume Next 'If Word is already running
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
'Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If
LastRow = .Range("E999").End(xlUp).Row 'Determine last row
LeftCell = .Range("B" & (ActiveCell.Row)).Value
For CustRow = 8 To LastRow
If LeftCell = 6 Then
Set WordDoc = WordApp.Documents.Open("C:\Users\jhabermann\Desktop\Excel VBA Test Environment\Template 1.docx", ReadOnly:=False) 'Open Template
ElseIf LeftCell = 4 Then
Set WordDoc = WordApp.Documents.Open("C:\Users\jhabermann\Desktop\Excel VBA Test Environment\Template 2", ReadOnly:=False) 'Open Template
Else: LeftCell = 3
Set WordDoc = WordApp.Documents.Open("C:\Users\jhabermann\Desktop\Excel VBA Test Environment\Template 3.docx", ReadOnly:=False) 'Open Template
End If
For CustCol = 5 To 10 'Move through 3 columns
TagName = .Cells(7, CustCol).Value 'Tag Name
TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue
End With
Next CustCol
WordDoc.PrintOut
WordDoc.Close
Kill (FileName) 'Deletes the Word File just created
Next CustRow
WordApp.Quit
End With
End Sub
Ignore the few lines of code regarding b3 and g3, I am saving that for later functionality to perhaps choose different sets of templates.

You need to move Leftcell inside your loop and increment it with every iteration:
For CustRow = 8 To LastRow
LeftCell = .Range("B" & CustRow).Value
If LeftCell = 6 Then
Set WordDoc = WordApp.Documents.Open("C:\Users\jhabermann\Desktop\Excel VBA Test Environment\Template 1.docx", ReadOnly:=False) 'Open Template
ElseIf LeftCell = 4 Then
Set WordDoc = WordApp.Documents.Open("C:\Users\jhabermann\Desktop\Excel VBA Test Environment\Template 2", ReadOnly:=False) 'Open Template
Else: LeftCell = 3
Set WordDoc = WordApp.Documents.Open("C:\Users\jhabermann\Desktop\Excel VBA Test Environment\Template 3.docx", ReadOnly:=False) 'Open Template
End If
For CustCol = 5 To 10 'Move through 3 columns
TagName = .Cells(7, CustCol).Value 'Tag Name
TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue
End With
Next CustCol
WordDoc.PrintOut
WordDoc.Close
Kill (FileName) 'Deletes the Word File just created
Next CustRow
As a note, not sure what you're doing on that Else: LeftCell = 3 line - why set LeftCell to anything? I think you meant for another ElseIf there.

Related

Extract specific data from Word to Excel

I have a Word file that has table with 5 columns: Step, Document, Doc #, Compo and Lot #, Sign, Date. I need to search for "Lot #" and "E#" in the word file then get the Step number, the text of row contains the string into an Excel file. I found a code that need to have the keywords in Sheet 1 of Excel then extract the data from Word into Sheet 2 with 1st column as keyword, 2nd column as row number in Word and 3rd column is the text of that row.
Is there any way I can hard code the keywords with options/message box to choose the keyword into VBA module instead of Sheet 1 and get the data in Sheet 1 with 1st column as keyword, 2nd column as the value in Step column in Word and 3rd column is the text of that row?
I'm pretty new to VBA so I don't know how to implement those.
Sub LocateSearchItem()
Dim shtSearchItem As Worksheet
Dim shtExtract As Worksheet
Dim oWord As Word.Application
Dim WordNotOpen As Boolean
Dim oDoc As Word.Document
Dim oRange As Word.Range
Dim LastRow As Long ' last row with data in shtSearchItem
Dim CurrRowShtSearchItem As Long ' current row in shtSearchItem
Dim CurrRowShtExtract As Long ' current row in shtExtract
Dim myPara As Long
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set oDoc = GetObject(wdFileName) 'open Word file
If Err Then
Set oWord = New Word.Application
WordNotOpen = True
End If
On Error GoTo Err_Handler
oWord.Visible = True
oWord.Activate
Set shtSearchItem = ThisWorkbook.Worksheets(1)
If ThisWorkbook.Worksheets.Count < 2 Then
ThisWorkbook.Worksheets.Add After:=shtSearchItem
End If
Set shtExtract = ThisWorkbook.Worksheets(2)
LastRow = shtSearchItem.UsedRange.Rows(shtSearchItem.UsedRange.Rows.Count).Row
For CurrRowShtSearchItem = 2 To LastRow
Set oRange = oDoc.Range
With oRange.Find
.Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
.MatchCase = False
.MatchWholeWord = True
While oRange.Find.Execute = True
oRange.Select
myPara = oDoc.Range(0, oWord.Selection.Paragraphs(1).Range.End).Paragraphs.Count
CurrRowShtExtract = CurrRowShtExtract + 1
shtExtract.Cells(CurrRowShtExtract, 1).Value = .Text
shtExtract.Cells(CurrRowShtExtract, 2).Value = myPara
shtExtract.Cells(CurrRowShtExtract, 3) = oDoc.Paragraphs(myPara).Range
oRange.Collapse wdCollapseEnd
Wend
End With
Next CurrRowShtSearchItem
If WordNotOpen Then
oWord.Quit
End If
'Release object references
Set oWord = Nothing
Set oDoc = Nothing
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
If WordNotOpen Then
oWord.Quit
End If
End Sub
What I got from the current code

Excel to Word VBA. Create Hover Texts for 25k Definitions

What is the BEST option to create Hover Texts for 25k Definitions?
(Excel to Word using VBA)
Screen Tips?
Tool Tips?
Foot Notes?
Glossary?
Book Marks?
Other Options?
Over 25K Definitions in Table
Based on feedback and countless HOURS, Im having a tough time figuring out the best option for a Text Hover Effect.
Ive tried Bookmarks and Screen Tips and ran into many issues.
Ive also attempted to tweak the below VBA code to work with Hyperlinks to no avail.
3 STEPS
Select the Term from Column:A
Find the Term in Word Document
ADD Definition From Column:B as a HOVER effect in Word
| Column A | Column B |
| ----------- | ------------------------ |
| Example A | Definition Example.... |
| Example B | Definition Example.... |
Column: A1:A25000 = Term
Column: B1:B25000 = Definition
*The below code works great for finding and highlighting the Terms, But I haven't figured out the Hover Effect.
Favor 2023
`'Version #1: Only loops through Word Document Content for text to Find and Replace.
'Leverage & Lean "Less Clicks, More Results"
Sub FindReplaceAcrossMultipleWordDocumentsFreeMacro()
' Means variable is in use
Dim FindReplaceCounter As Integer '
Dim FolderPath As String '
Dim LastRow As Integer '
Dim LastRowPath As Integer '
Dim MyRange As Object '
Dim oFile As Object '
Dim oFolder As Object '
Dim oFSO As Object '
Dim WordApp As New Word.Application '
Dim WordCounter As Integer '
Dim WordDocument As Object '
On Error GoTo LeverageLean
Set WordApp = New Word.Application 'Forces a New Word Application each and every time. (Prevents Error 462)
If Cells(2, 3).Value <> "" Then 'If a path to Word Documents exist
WordCounter = 2
LastRowPath = Cells(Rows.Count, 3).End(xlUp).Row 'Identify Last Row in Column C
Do Until WordCounter > LastRowPath 'Loop through any Word Documents in Column C
Set WordDocument = WordApp.Documents.Open(Cells(WordCounter, 3).Value)
WordApp.Visible = True
FindReplaceCounter = 2
LastRow = Cells(Rows.Count, 1).End(xlUp).Row 'Identify Last Row in Column A
Do Until FindReplaceCounter > LastRow 'Complete the Find and Replace for all values in Column A & B
Set MyRange = WordApp.ActiveDocument.Content
With MyRange.Find
.Format = True
.MatchWholeWord = True
'.MatchWildcards = True 'Find and Replace Uppercase & Lowercase Text
.Wrap = wdFindContinue
.Forward = True
.Text = Cells(FindReplaceCounter, 1).Value
'.Replacement.Highlight = True 'Highlight the Replacement Text Found
.Replacement.Text = Cells(FindReplaceCounter, 2).Value
.Execute Replace:=wdReplaceAll
End With
FindReplaceCounter = FindReplaceCounter + 1
Loop
WordApp.ActiveDocument.Save
WordApp.ActiveDocument.Close 'Close Active Word Document
WordCounter = WordCounter + 1
Loop
ElseIf Cells(2, 3).Value = "" Then 'If NO paths to Word Documents exist
FolderPath = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - Len(ActiveWorkbook.Name)) 'Active Workbook File Path
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(FolderPath)
For Each oFile In oFolder.Files 'Loop through every File in Active Workbook's folder path
If InStr(1, oFile.Type, "Microsoft Word") <> 0 And InStr(1, oFile.Name, "~") = 0 Then 'If the File Type contains the phrase Microsoft Word and is NOT Lock File
Set WordDocument = WordApp.Documents.Open(FolderPath & oFile.Name)
WordApp.Visible = True
FindReplaceCounter = 2
LastRow = Cells(Rows.Count, 1).End(xlUp).Row 'Identify Last Row in Column A
Do Until FindReplaceCounter > LastRow 'Complete the Find and Replace for all values in Column A & B
Set MyRange = WordApp.ActiveDocument.Content
With MyRange.Find
.Format = True
.MatchWholeWord = True
.Wrap = wdFindContinue
.Forward = True
.Text = Cells(FindReplaceCounter, 1).Value
'.Replacement.Highlight = True 'Highlight the Replacement Text Found
.Replacement.Text = Cells(FindReplaceCounter, 2).Value
.Execute Replace:=wdReplaceAll
End With
FindReplaceCounter = FindReplaceCounter + 1
Loop
WordApp.ActiveDocument.Save
WordApp.ActiveDocument.Close 'Close Active Word Document
End If
Next oFile
End If
WordApp.Quit
MsgBox "The Find and Replace has been completed. Stay Awesome!"
Set oFSO = Nothing
Set oFolder = Nothing
Set oFile = Nothing
Set WordApp = Nothing
Set WordDocument = Nothing
Exit Sub
LeverageLean:
MsgBox (Err.Number & " - " & Err.Description & vbNewLine & vbNewLine & "Don't hesitate to email me: brentschneider#leveragelean.com")
End Sub
'Stay Awesome`

Copy and Paste or append file from excel to word doc

ok, so here we go, I have tried to conquer this on my own for the past two days have have tried a lot of solutions. I am working with data in a Excel Spreadsheet that populates a word file. The specific problem I have is placing a table at the end of the word document. I have tried to create the table, and append a word doc that just has the table in it. nether seems to get done. My latest attempt was to just use sendkeys to copy and paste the table from the open documents.
I am willing to try anything at this point, short of doing it manually as I have to generate thousands of files.
Stripped code is below:
Option Explicit
Sub CreateWordDocuments()
Dim CustRow, CustCol, LastRow, TemplRow, DaysSince, FrDays, ToDays As Long
Dim DocLoc, TagName, TemplName, FileName As String
Dim TagValue As String
Dim myData As DataObject
Dim CurDt As Date
Dim LastAppDt As Date
Dim WordDoc As Object
Dim WordTable As Object
Dim WordApp As Object
Dim WordContent As Word.Range
Dim oWorkbookEA As Workbook
Set oWorkbookEA = Workbooks.Open(FileName:="M:\Form.xlsx")
Set myData = New DataObject
Dim oTable As Table
Dim oCell As Cell
Dim oPrevRow As Row, oNewRow As Row
Dim iColumn As Long
Dim myRange As Range
Dim NoCol As Integer
Dim NoRow As Integer
With Sheet1
DocLoc = "M:\WIP_Rev4.docx" 'Word Document Filename
'Open Word Template
On Error Resume Next 'If Word is already running
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
'Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If
Set WordTable = WordApp.Documents.Open(FileName:="M:\Table.docx", ReadOnly:=True)
LastRow = .Range("E9999").End(xlUp).Row 'Determine Last Row in Table
For CustRow = 6 To 7 'LastRow
DaysSince = .Range("M" & CustRow).Value
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
'For CustCol = 5 To 13 'Move Through 9 Columns
TagValue = .Cells(CustRow, 2).Value 'Tag Value
With WordDoc.Content.Find
.Text = "$Product$"
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Find & Replace all instances
End With
myData.SetText oWorkbookEA.Sheets("Company Info").Shapes("TextBox 6").TextFrame.Characters.Text
myData.PutInClipboard
With WordDoc.Content.Find
.Text = "$VarS$"
.Replacement.Text = "^c"
.Wrap = wdFindStop
.Execute Replace:=wdReplaceOne 'Find & Replace all instances
End With
myData.SetText oWorkbookEA.Sheets("Company Info").Shapes("TextBox 14").TextFrame.Characters.Text
myData.PutInClipboard
'This table works fine as it is preexisting
Set oTable = WordDoc.Tables(4)
Set oPrevRow = oTable.Rows(oTable.Rows.Count)
oPrevRow.Cells(1).Range.Text = "Ingredient Name"
oPrevRow.Cells(2).Range.Text = "No."
oPrevRow.Cells(3).Range.Text = "Percentage"
oTable.Rows.Add
Set oNewRow = oTable.Rows(oTable.Rows.Count)
oNewRow.Cells(1).Range.Text = "Lidocaine"
oNewRow.Cells(2).Range.Text = ""
oNewRow.Cells(3).Range.Text = Format(.Range("E" & CustRow).Value, "#.#%")
oTable.Rows.Add
Set oNewRow = oTable.Rows(oTable.Rows.Count)
oNewRow.Cells(1).Range.Text = "Glycol"
oNewRow.Cells(2).Range.Text = ""
oNewRow.Cells(3).Range.Text = Format(.Range("F" & CustRow).Value, "#.#%")
oTable.Rows.Add
Set oNewRow = oTable.Rows(oTable.Rows.Count)
oNewRow.Cells(1).Range.Text = "Glycerin"
oNewRow.Cells(2).Range.Text = ""
oNewRow.Cells(3).Range.Text = Format(.Range("G" & CustRow).Value, "#.#%")
'With WordDoc
' .Tables(.Tables.Count).Rows(1).Cells(1).Select
' MsgBox (.Tables.Count)
'End With
With oTable.Borders
.InsideLineStyle = wdLineStyleSingle
'.OutsideLineStyle = wdLineStyleDouble
End With
'The begining of my problems
WordDoc.Selection.Collapse Direction:=wdCollapseEnd
WordTable.Active
WordTable.SendKeys ("^a")
WordTable.SendKeys ("^c")
WordDoc.Active
WordDoc.SendKeys ("^v")
FileName = ThisWorkbook.Path & "\" & .Range("A" & CustRow).Value & "_" & ".pdf" 'Create full filename & Path with current workbook location, Last Name & First Name
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
.Range("N" & CustRow).Value = TemplName 'Template Name
.Range("O" & CustRow).Value = Now
WordDoc.PrintOut
WordDoc.Close
'Kill (FileName) 'Deletes the PDF or Word that was just created
Next CustRow
WordApp.Quit
End With
End Sub
Table document is Table.docx that I have tried to append to the end. That would be my ideal solution.
Thanks for any help you can give
Here's an example of copying a table from one document and pasting it at the end of another:
Sub Tester()
Dim wd As Word.Application
Dim docTbl As Word.Document, docMain As Word.Document
Dim tbl As Word.Table, objRange As Word.Range
Set wd = GetObject(, "Word.application") 'Word already running with the 2 docs open
Set docMain = wd.Documents("Document1")
Set docTbl = wd.Documents("Document2")
Set tbl = docTbl.Tables(1)
tbl.Range.Copy '<< copy the table
Set objRange = docMain.Content
objRange.Collapse Direction:=0 'wdCollapseEnd
objRange.InsertAfter vbCrLf
objRange.Collapse Direction:=0
objRange.Paste '<< paste the table
End Sub
FYI I find the dataobject.putinclipboard approach pretty unreliable in later versions of Excel, so I'd avoid that if you can.

Use excel to change a Word file template

I created a code that sopose to take a Word file template and fill it with data from my excel table.
Sub CreateWordDocs()
Dim CustRow, CustCol, LastRow, TemplRow As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim WordDoc, WordApp As Object
With Sheet1
If ActiveCell.Value = Empty Then
MsgBox "pick a different cell"
End If
DocLoc = Sheet2.Range("K2").Value
'Open File
On Error Resume Next 'if Word ia already running
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
End If
LastRow = .Range("B999").End(xlUp).Row
For CustRow = ActiveCell.Row To LastRow
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False)
For CustCol = 2 To 8
TagName = Cells(3, CustCol)
TagValue = Cells(CustRow, CustCol).Value
With WordDoc.Content.find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next CustCol
FileName = ThisWorkbook.Path & "\" & .Range("B" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
Next CustRow
WordDoc.Display
End With
End Sub
when I run the code it just opens Word without creating any file....
I am assuming here:
If ActiveCell.Value = Empty Then
MsgBox "pick a different cell"
End If
you wanted the code to stop executing if the selected cell in your Excel Worksheet was empty. If so, then you need to put a Exit Sub after MsgBox:
If ActiveCell.Value = Empty Then
MsgBox "pick a different cell"
Exit Sub
End If
I am also assuming that you have at least two Worksheets in your Excel doc because of:
Line 5: With Sheet1
Line 11: DocLoc = Sheet2.Range("K2").Value
It seems that you only use Sheet2 in your code to get the path of your Word Template, and everything else (Cells and Range statements) is meant to be referenced to Sheet1.
Even if the above assumptions are correct, it is not clear if you want to close the re-saved Word documents once they are filled.
If you don't close the individual Word docs once they are filled and saved, you may end up having huge amount of Word documents open depending how many Customers you have in your Excel Worksheet.
Your PC may run out of free memory, slows down very much, or who knows.
Based on the above assumptions, I made some changes in your code to make it run.
Let me know if you wanted it to do something else.
Make sure you have Microsoft Word Object Library enabled in VBA Editor, Tools -> References.
Depending on the version of your Office installed, the module to be enabled might have a different version number.
This is the complete code block after the edits:
Sub CreateWordDocs()
Dim CustRow, CustCol, LastRow, TemplRow As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim WordDoc, WordApp As Object
Dim WBook As Workbook
Set WBook = Application.ActiveWorkbook
Dim Sheet1 As Worksheet
Dim Sheet2 As Worksheet
Set Sheet1 = WBook.Worksheets(1)
Set Sheet2 = WBook.Worksheets(2)
With Sheet1
If ActiveCell.Value = "" Then
MsgBox "pick a different cell"
Exit Sub
End If
DocLoc = Sheet2.Range("K2").Value
On Error Resume Next
'Set WordApp = GetObject("Word.Application")
Set WordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
End If
'LastRow = .Range("B999").End(xlUp).Row
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For CustRow = ActiveCell.Row To LastRow
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False)
For CustCol = 2 To 8
TagName = .Cells(3, CustCol).Value
TagValue = .Cells(CustRow, CustCol).Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next CustCol
FileName = ThisWorkbook.Path & "\" & .Range("B" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
WordDoc.Close
Next CustRow
'WordDoc.Display
End With
End Sub

Copy formatted text from excel to word

I have an excel sheet with two columns of strings. I track the changes of these two columns using ms-word and copy the result back to a third column. Then I copy the third column to a new word document.
The formating in Excel in Cell C3 is what I would like to transfer to word.
This is what I get at the moment. Notice the complete strike-through.
Why does it work twice but not in the third case?
I guess the root of the problem is that I remove the CR/Linefeed in the word to excel step and destroy the boundary of the strike-through-format. My goal is to get each string in one word-paragraph. If I don't remove the CR/Linefeed i get four paragraphs.
Background: In the final application the strings are going to be paragraphs of text.
Sourcecode of the excel-vba-macro (Excel 2010):
Technical remark: You may need to activate the ms-word-objects in excel-vba. (Microsoft Word 14.0 Object Library )
The macro assumes, that there a strings in the Range(A1:B3):
for example
a string a string, too
a string a new string
a string there is no try
The results will be put in the Range(C1:C3).
Option Explicit
Dim numberOfBlocks As Long
Sub main()
Dim i As Long
Dim tSht As Worksheet
Dim wordapp As Word.Application
Dim wdoc As Word.Document
Set tSht = ThisWorkbook.ActiveSheet
numberOfBlocks = 3
Application.ScreenUpdating = False
Set wordapp = CreateObject("Word.Application")
For i = 1 To numberOfBlocks
Call trackChanges(i, wordapp, tSht)
Next i
Set wdoc = wordapp.Documents.Add
Call copyChanges(tSht, wdoc)
End Sub
Sub trackChanges(i As Long, wordapp As Word.Application, tSht As Worksheet)
Dim diffDoc As Word.Document
Dim textString() As Variant
Dim j As Long
ReDim doc(2)
ReDim textString(2)
Set textString(1) = tSht.Range("A" & i)
Set textString(2) = tSht.Range("B" & i)
For j = 1 To 2
With wordapp
Set doc(j) = .Documents.Add
textString(j).Copy
doc(j).Paragraphs(1).Range.PasteSpecial
End With
Next j
wordapp.CompareDocuments OriginalDocument:=doc(1), RevisedDocument:=doc(2), _
Destination:=wdCompareDestinationNew, Granularity:=wdGranularityCharLevel
For j = 1 To 2
doc(j).Close SaveChanges:=False
Next j
Set diffDoc = wordapp.ActiveDocument
wordapp.Visible = True
'if the answer has two paragraphs, get both in one paragraph
With diffDoc.Content.Find
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Text = vbCrLf
.Replacement.Text = " "
.Execute Replace:=wdReplaceAll
End With
diffDoc.Range.Copy
tSht.Range("C" & i).Select
tSht.PasteSpecial Format:="HTML"
With tSht.Range("C" & i)
.WrapText = True
.Font.Name = textString(2).Font.Name
.Font.Bold = textString(2).Font.Bold
.Font.Size = textString(2).Font.Size
.Rows.AutoFit
.Interior.Color = textString(2).Interior.Color
End With
diffDoc.Close SaveChanges:=False
Application.CutCopyMode = False
Set diffDoc = Nothing
End Sub
Sub copyChanges(tSht As Worksheet, wdoc As Word.Document)
tSht.Range("C1:C" & numberOfBlocks).Copy
wdoc.Range(wdoc.Range.End - 1, wdoc.Range.End).PasteSpecial Placement:=wdInLine, DataType:=wdPasteHTML
wdoc.Tables(1).ConvertToText Separator:=wdSeparateByParagraphs
End Sub

Resources