大佬教程收集整理的这篇文章主要介绍了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,""))) <> 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
在我看来，您的代码可以变得更高效和更短：
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
以上是大佬教程为你收集整理的VBA Excel 转 Word 内容控件运行缓慢全部内容，希望文章能够帮你解决VBA Excel 转 Word 内容控件运行缓慢所遇到的程序开发问题。
如果觉得大佬教程网站内容还不错，欢迎将大佬教程推荐给程序员好友。
本图文内容来源于网友网络收集整理提供，作为学习参考使用，版权属于原作者。
如您有任何意见或建议可联系处理。小编QQ：384754419，请注明来意。