Excel VBA-自动将多个图表插入到书签中的单词中？

Question

在将多个聊天记录和表格粘贴到已定义书签中的单词时，我很难将Autofit添加到子项中。 我尝试了多种方法，但是我缺乏经验，这说明我无法通过添加或添加自动调整功能来使子菜单失败或无法自动调整。

它运行良好，如下所示：

'To open a template word file '"C:\Users\USER\Documents\Custom Office  Templates\Test161231.dotm"
'To copy ranges and charts as referenced on this excel workbook sheet "Bookmarks"
'To paste ranges and charts at predefined bookmarks within the open word    template as referenced on this excel workbook sheet "Bookmarks"
'To save the open word template as a .Docx

Sub OpenPopulateSave()

Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
Dim x               As Long
Dim LastRow         As Long
Dim SheetChart      As String
Dim SheetRange      As String
Dim BookMarkChart   As String
Dim BookMarkRange   As String
Dim Prompt          As String
Dim Title           As String

'Turn some stuff off while the macro is running
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

'Determine the last row of data for our loop
LastRow = Sheets("Bookmarks").Range("A" & Rows.Count).End(xlUp).Row

'Create an instance of Word for us to use
Set wApp = CreateObject("Word.Application")

'Open our specified Word file, On Error is used in case the file is not there
On Error Resume Next
Set wDoc = wApp.Documents.Open("C:\Users\USER\Documents\Custom Office Templates\Test161231.dotm", ReadOnly:=True)
On Error GoTo 0

'If the file is not found, we need to end the sub and let the user know
If wDoc Is Nothing Then
    MsgBox "Unable to find the Word file.", vbCritical, "File Not Found"
    wApp.Quit
    Set wApp = Nothing
    Exit Sub
End If

'Copy/Paste Loop starts here
For x = 2 To 20

'Use the Status Bar to let the user know what the current progress is
Prompt = "Copying Data: " & x - 1 & " of " & LastRow - 1 & "   (" & _
    Format((x - 1) / (LastRow - 1), "Percent") & ")"
Application.StatusBar = Prompt

'Assign the worksheet names and bookmark names to a variable
'Use With to group these lines together
With ThisWorkbook.Sheets("Bookmarks")
    SheetChart = .Range("A" & x).Text
    SheetRange = .Range("B" & x).Text
    BookMarkChart = .Range("C" & x).Text
    BookMarkRange = .Range("D" & x).Text

End With

If Len(BookMarkRange) > 0 Then
'Tell Word to goto the bookmark assigned to the variable BookMarkRange
wApp.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkRange

'Copy the data from Thisworkbook
ThisWorkbook.Sheets(SheetRange).UsedRange.Copy

'Paste into Word
wApp.Selection.Paste

'Autofit Table so it fits inside Word Document window
'?

End If

If Len(BookMarkChart) > 0 Then
'Tell Word to goto the bookmark assigned to the variable BookMarkChart
wApp.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkChart

   'Copy the data from Thisworkbook
ThisWorkbook.Sheets(SheetChart).ChartObjects(1).Copy

'Paste into Word
wApp.Selection.Paste

'Autofit Chart so it fits inside Word Document window
'?

End If

Next

'Turn everything back on
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.StatusBar = False

'Let the user know the procedure is now complete
Prompt = "Your report has now been generated." & vbCrLf & vbCrLf & "You may now edit the word document."
Title = "Procedure Completion"
MsgBox Prompt, vbOKOnly + vbInformation, Title

'Make our Word session visible
wApp.Visible = True

With wDoc

.SaveAs ActiveWorkbook.Path & Application.PathSeparator & "Test3_" & Format(Now, "yyyy-mm-dd hh-mm") & ".docx", FileFormat:=wdFormatXMLDocument
wApp.DisplayAlerts = True

End With

'Clean up
Set wApp = Nothing
Set wDoc = Nothing

End Sub

任何帮助和其他有用的意见，将不胜感激！ 我仍处于早期学习阶段。

Answer 1

我可以立即找到以下内容：

1. 您使用Set wApp = CreateObject("Word.Application")两次（在变量声明期间和LastRow = Sheets("Bookmarks").Range("A" & Rows.Count).End(xlUp).Row ）
2. 当您通过Exit Sub停止代码时，请注意，您再次打开了“一些东西”（ScreenUpdating，警报，事件）（请参阅： If wDoc Is Nothing Then ）
3. 您开始For x = 2 To 20循环，但是您从未真正循环（没有next x ）
4. 我猜想您想在循环中使用LastRow结果（ For x = 2 To LastRow ）。
5. 对于自动Dim WordTable As Word.Table ，请尝试： Set WordTable = myDoc.Tables(1) Dim WordTable As Word.Table ， Set WordTable = myDoc.Tables(1) ，将WordTable.AutoFitBehavior (wdAutoFitWindow)