Управление содержимым VBA Excel в Word работает медленно

У меня есть простой интерфейс в Excel, который позволяет пользователю экспортировать таблицу из Excel в Word как новый или существующий документ. Затем он перебирает последний столбец (8) в таблице слов и вставляет раскрывающийся список в каждую ячейку.

Код делает то, что должен, но работает медленно при вставке элементов управления содержимым. Кроме того, я вижу, что он вставляет каждый элемент управления содержимым в MS Word, что говорит мне о том, что обновление экрана не отключено в Word. Любые предложения, чтобы мой код работал быстрее?

Полный код и таблица справочных слов ниже.

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