我对VBA来说还比较陌生，已经观看了一些教程视频/阅读了一些博客，以开始关注我。我已经尝试使用此页面https://www.datawright.com.au/other/word_bookbark_vba_code_sample.htm中的示例代码来编写/编辑我的第一个工作代码，还尝试了一些教程对其进行编辑。
[有点背景...我使用Microsoft Word（具有启用宏的模板）编写了大量报告，并从Excel（也是启用宏的模型）导入数据。我在报表模板中放置了各种书签，以使用以下代码通过“链接”到Excel来填充（对于图片，它调用一个范围，并将该范围复制/粘贴为图像）。 注意此代码在Microsoft Word中存储为宏按钮。
代码确实有效，但是很长，所以我想知道是否有人对它进行压缩或改进有任何技巧？
另外，有人能够向我展示如何选择退出marco吗？目前，我拥有它，因此它迫使您选择Excel兼容的文档，并且在选择该文档之前您不能退出对话框。我正在考虑在代码的开头使用MsgBox来让用户确认他们是否要继续/不继续进行此过程。
感谢任何建议！下面提供了代码。
Option Explicit
Sub Populate_Fields()
Dim objExcel As Object, _
objWbk As Object, _
objDoc As Document
Dim sWbkName As String
Dim sBookmark As String, _
sRange As String, _
sSheet As String, _
sType As String
Dim i As Integer
Dim vNames()
Dim dlgOpen As FileDialog
Dim bnExcel As Boolean
Dim intCounter As Integer
Dim blnCloseWorkbook As Boolean
On Error GoTo Err_Handle
Set objDoc = ActiveDocument
Set dlgOpen = Application.FileDialog(FileDialogType:=msoFileDialogOpen)
bnExcel = False
Do Until bnExcel = True
With dlgOpen
.AllowMultiSelect = True
.Show
If .SelectedItems.Count > 0 Then
sWbkName = .SelectedItems(1)
Else
MsgBox "Please select a workbook to use for processing"
End If
End With
If InStr(1, sWbkName, ".xls") > 0 Then
'proceed
bnExcel = True
Else
MsgBox "The file must be a valid Excel file. Try again please..."
End If
Loop
Application.ScreenUpdating = False
blnCloseWorkbook = True
'check to see that the Excel file is open. If not, open the file
'also grab the wbk name to enable switching
Set objExcel = GetObject(, "Excel.Application")
For i = 1 To objExcel.workbooks.Count
If LCase(objExcel.workbooks(i).FullName) = LCase(sWbkName) Then
Set objWbk = objExcel.workbooks(i)
blnCloseWorkbook = False
Exit For
End If
Next
If objWbk Is Nothing Then
Set objWbk = objExcel.workbooks.Open(sWbkName)
End If
'switch to Excel, find range name that corresponds to the bookmark
'objExcel.Visible = False
'objWbk.Activate
vNames = objWbk.Worksheets("Report").Range("Bookmarks").Value
'loop through the bookmarks listed in the Excel range,
'and if they exist in the current document, populate them
For intCounter = LBound(vNames) To UBound(vNames)
sBookmark = vNames(intCounter, 1)
sSheet = vNames(intCounter, 2)
sRange = vNames(intCounter, 3)
sType = vNames(intCounter, 4)
If objDoc.Bookmarks.Exists(sBookmark) = True Then
On Error Resume Next
If sType = "Table" Then
'If section to be copied is a table
objWbk.Worksheets(sSheet).Range(sRange).CopyPicture 1, -4147
Call UpdateBookmarkField(objDoc, sBookmark, " ")
Call UpdateBookmarkTableorChart(objDoc, sBookmark, sType)
ElseIf sType = "Chart" Then
'If section to be copied is a graph/chart
objWbk.Worksheets(sSheet).ChartObjects(sRange).Copy
Call UpdateBookmarkField(objDoc, sBookmark, " ")
Call UpdateBookmarkTableorChart(objDoc, sBookmark, sType)
Else
'Do this routine if the section is a field
Call UpdateBookmarkField(objDoc, sBookmark, objWbk.Worksheets(sSheet).Range(sRange))
End If
On Error GoTo 0
End If
Next intCounter
If blnCloseWorkbook = True Then
objWbk.Close True
End If
objDoc.Activate
Err_Exit:
'clean up
Set objWbk = Nothing
objExcel.Visible = True
Set objExcel = Nothing
Set objDoc = Nothing
Application.ScreenUpdating = True
Application.ScreenRefresh
MsgBox "The document has been updated"
Err_Handle:
If Err.Number = 429 Then 'excel not running; launch Excel
Set objExcel = CreateObject("Excel.Application")
Resume Next
ElseIf Err.Number = 9 Then 'excel not running; launch Excel
Set objExcel = CreateObject("Excel.Application")
Resume Next
ElseIf Err.Number <> 0 Then
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Err_Exit
End If
End Sub
Sub UpdateBookmarkField(docPopulate As Document, strBookmarkName As String, strBookmarkValue As String)
Dim rngBookmarkRange As Range
If docPopulate.Bookmarks.Exists(strBookmarkName) = False Then
Exit Sub
End If
Set rngBookmarkRange = docPopulate.Bookmarks(strBookmarkName).Range
rngBookmarkRange.Text = strBookmarkValue
docPopulate.Bookmarks.Add Name:=strBookmarkName, Range:=rngBookmarkRange
Set rngBookmarkRange = Nothing
End Sub
Sub UpdateBookmarkTableorChart(docPopulate As Document, strBookmarkName As String, strType As String)
Dim rngBookmarkRange As Range
Dim DefaultWrapType As WdWrapType
Dim blnSmartPaste As Boolean
If docPopulate.Bookmarks.Exists(strBookmarkName) = False Then
Exit Sub
End If
DefaultWrapType = Options.PictureWrapType
blnSmartPaste = Options.SmartCutPaste
Set rngBookmarkRange = docPopulate.Bookmarks(strBookmarkName).Range
rngBookmarkRange.Collapse direction:=wdCollapseStart
Options.PictureWrapType = wdWrapMergeInline
Options.SmartCutPaste = False
If strType = "Chart" Then
rngBookmarkRange.PasteAndFormat (wdChartPicture)
Else
rngBookmarkRange.PasteAndFormat (wdPasteDefault)
End If
docPopulate.Bookmarks(strBookmarkName).Range.Characters.Last.Delete
Options.PictureWrapType = DefaultWrapType
Options.SmartCutPaste = blnSmartPaste
Set rngBookmarkRange = Nothing
End Sub
堆栈溢出用于解决错误。您的第一个问题更适合https://codereview.stackexchange.com，因为您的代码可以正常运行且没有错误。
关于第二个问题...如果您替换
MsgBox "Please select a workbook to use for processing"
使用
Exit Sub
然后，如果用户关闭对话框窗口而不选择文件，则程序将退出。
这违反了单一出口点原则，您应该记住，如果不满足工作簿或预期条件，则任何先前调用的代码都将继续执行，并且可能会引发错误。