VBA Excel to Word Content Control Running Slowly - excel

Question

I have a simple interface in Excel that allows the user to export a table from Excel to Word as a new or existing document. It then loops through the last column(8) in the word table and inserts a drop down list in each cell.
The code does what it is supposed to do but runs slowly when inserting the content controls. Additionally, I can see it insert each content control in MS Word which tells me that screen updating is not disabled in Word. Any suggestions to make my code to run faster?
Full code and reference word table below.
Sub ExportToWord()
Dim ws As Excel.Worksheet
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim objRange As Word.Range
Dim newDoc As Boolean
Dim rng As Excel.Range
Dim lRow As Integer, s As Integer
Dim objCC As ContentControl
Dim counter As Long
Dim oRow As Row
If UF_Load.check_new = True Then
newDoc = True
Else
newDoc = False
End If
Set ws = ThisWorkbook.Sheets("UI")
Application.ScreenUpdating = False
Application.EnableEvents = False
s = ws.Range("rng_demo").Row - 2
c = ws.Range("rng_demo").Column
lRow = ws.Cells(Rows.Count, s).End(xlUp).Row
Set rng = ws.Range("A" & s).Resize(lRow, 8)
rng.Copy
If wrdApp Is Nothing Then
On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
If Err.Number > 0 Then Set wrdApp = CreateObject("Word.Application")
On Error GoTo 0
End If
'Handle if Word Application is not found
If Err.Number <> 0 Then GoTo SafeExit:
'MsgBox "Microsoft Word document could not be found, aborting", vbExclamtion, "Microsoft Word Error 429"
'GoTo SafeExit:
'End If
On Error GoTo 0
'Make MS Word Visible and Active
wrdApp.Activate
wrdApp.Visible = True
If newDoc = True Then
Set wrdDoc = wrdApp.Documents.Add 'create as new word document
'Set as editable
If wrdDoc.ActiveWindow.View.SplitSpecial = wdPaneNone Then
wrdDoc.ActiveWindow.ActivePane.View.Type = wdPrintView
Else
wrdDoc.ActiveWindow.View.Type = wdPrintView
End If
'Copy table data to word doc
Set tbl = rng
tbl.Copy
'Paste Table into Word doc
wrdDoc.Paragraphs(1).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit table to Word doc
Set Wordtable = wrdDoc.Tables(1)
Wordtable.AutoFitBehavior (wdAutoFitWindow)
'Dim oRng As Range
'Loop through last table column and add Combobox
'Insert comboboxes
With Wordtable
counter = 0
For Each oRow In Wordtable.Rows
'Set oRng = oRow.Cells(1).Range
'If Trim(Len(oRow.Cells(1).Range.Text)) <> " " Then
If Len(Trim(Replace(oRow.Cells(1).Range.Text, Chr(160), ""))) <> 2 And counter >= 8 Then 'GoTo Nexti:
On Error Resume Next
Set objCC = wrdApp.ActiveDocument.ContentControls.Add(wdContentControlDropdownList, oRow.Cells(8).Range)
If Err.Number = 5941 Then GoTo Nexti:
objCC.Title = "Interpretation"
If objCC.ShowingPlaceholderText Then
objCC.SetPlaceholderText , , "-"
objCC.DropdownListEntries.Add "Valid"
objCC.DropdownListEntries.Add "Significant Difference"
objCC.DropdownListEntries.Add "WNL"
objCC.DropdownListEntries.Add "Slightly Below Expectations"
objCC.DropdownListEntries.Add "Below Expectations"
objCC.DropdownListEntries.Add "Far Below Expectations"
Debug.Print Len(oRow.Cells(7).Range.Text)
End If
Else
'Do nothing
End If
Nexti:
On Error GoTo 0
counter = counter + 1
Next
End With
On Error GoTo SafeExit:
Else
'or open an existing document
Set wrdDoc = wrdApp.Documents.Open(filepath, , False) 'wrdApp.Documents.Open("C:\Users\Apache Paint\Desktop\Clients\Stephen Schmitz\TestDocument.docx")
'Set as editable
If wrdDoc.ActiveWindow.View.SplitSpecial = wdPaneNone Then
wrdDoc.ActiveWindow.ActivePane.View.Type = wdPrintView
Else
wrdDoc.ActiveWindow.View.Type = wdPrintView
End If
'Copy table data to word doc
With wrdDoc
Set tbl1 = .Tables.Add(Range:=wrdDoc.Paragraphs.Last.Range, _
NumRows:=1, NumColumns:=8, _
AutoFitBehavior:=wdAutoFitWindow) 'autofit content 'DefaultTableBehavior:=wdWord9TableBehavior,
With tbl1
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
End With
Set tbl = rng
Set objRange = wrdDoc.Content
With objRange
.Collapse Direction:=0 'wdCollapseEnd
'.InsertAfter vbCrLf '<<< Error on line
.Collapse Direction:=0
.InsertBreak Type:=wdPageBreak
.Paste '<< paste the table
End With
'Autofit the document
Set Wordtable = objRange.Tables(1) 'Set Wordtable = objRange.Tables(1)
Wordtable.AutoFitBehavior (wdAutoFitWindow)
With Wordtable
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
'Insert comboboxes
counter = 0
For Each oRow In Wordtable.Rows
Set oRng = oRow.Cells(1).Range
If Len(Trim(Replace(oRow.Cells(1).Range.Text, Chr(160), ""))) <> 2 And counter >= 8 Then 'GoTo Nexti:
On Error Resume Next
Set objCC = wrdApp.ActiveDocument.ContentControls.Add(wdContentControlDropdownList, oRow.Cells(8).Range)
If Err.Number = 5941 Then GoTo Nexti2:
objCC.Title = "Interpretation"
If objCC.ShowingPlaceholderText Then
objCC.SetPlaceholderText , , "-"
objCC.DropdownListEntries.Add "Valid"
objCC.DropdownListEntries.Add "Significant Difference"
objCC.DropdownListEntries.Add "WNL"
objCC.DropdownListEntries.Add "Slightly Below Expectations"
objCC.DropdownListEntries.Add "Below Expectations"
objCC.DropdownListEntries.Add "Far Below Expectations"
Debug.Print Len(oRow.Cells(7).Range.Text)
End If
Else
'Do nothing
End If
Nexti2:
On Error GoTo 0
counter = counter + 1
Next
End With
End With
filepath = ""
End If
SafeExit:
If Err.Number <> 0 Then
Beep
MsgBox "Microsoft Excel has encountered an error and could not complete the Export to MS Word. Possible reasons are:" & vbNewLine & vbNewLine & _
"-Reference to Microsoft Word Object Library is not enabled" & vbNewLine & vbNewLine & "-The document opened in Read Only mode" & vbNewLine & vbNewLine & _
"-Code execution was interrupted because the was closed or altered during execution" & vbNewLine & vbNewLine & "-Document is already open in MS Word" _
, vbCritical, "Error"
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.CutCopyMode = False
End Sub

Answer 1

It seems to me your code could be made both more efficient and shorter:
Sub ExportToWord()
Application.ScreenUpdating = False: Application.EnableEvents = False
Dim ws As Excel.Worksheet, rng As Excel.Range, lRow As Long, c As Long, r As Long, newDoc As Boolean
Dim wrdApp As Word.Application, wrdDoc As Word.Document, wrdTbl As Word.Table, wrdCCtrl As Word.ContentControl
Const filepath As String = "C:\Users\Apache Paint\Desktop\Clients\Stephen Schmitz\TestDocument.docx"
Set ws = ThisWorkbook.Sheets("UI")
With ws
c = .Range("rng_demo").Column
r = .Range("rng_demo").Row - 2
lRow = .Cells(.Rows.Count, c).End(xlUp).Row
Set rng = .Range("A" & r).Resize(lRow, 8)
End With
If wrdApp Is Nothing Then
On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
If Err.Number > 0 Then Set wrdApp = CreateObject("Word.Application")
On Error GoTo 0
End If
With wrdApp
.Visible = True
If UF_Load.check_new = True = True Then
'create as new word document
Set wrdDoc = wrdApp.Documents.Add
'create a table
Set wrdTbl = wrdDoc.Tables.Add(Range:=wrdDoc.Paragraphs.Last.Range, NumRows:=1, NumColumns:=8)
Else
'open an existing document
Set wrdDoc = .Open(filepath, , False)
'copy & paste the Excel table
rng.Copy
Set wrdTbl = wrdDoc.Paragraphs.Last.Range.PasteExcelTable(LinkedToExcel:=False, WordFormatting:=False, RTF:=False)
End If
With wrdDoc
With wrdTbl
'format the table
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
'Insert comboboxes
For r = 9 To .Rows.Count
If r = 9 Then
Set wrdCCtrl = wrdDoc.ContentControls.Add(wdContentControlDropdownList, .Cell(r, 8).Range)
With wrdCCtrl
.Title = "Interpretation"
.SetPlaceholderText , , "-"
.DropdownListEntries.Add "Valid"
.DropdownListEntries.Add "Significant Difference"
.DropdownListEntries.Add "WNL"
.DropdownListEntries.Add "Slightly Below Expectations"
.DropdownListEntries.Add "Below Expectations"
.DropdownListEntries.Add "Far Below Expectations"
End With
Else
.Cell(r, 8).Range.FormattedText = wrdCCtrl.Range.FormattedText
End If
Next
End With
End With
End With
Application.ScreenUpdating = True: Application.EnableEvents = True: Application.CutCopyMode = False
End Sub