从Excel生成Microsoft Word报告 - 应用程序等待Ole Action?(VBA)

Question

我正在尝试编写一个宏，该宏将从Excel文件中生成Microsoft Word'Report'。我想让宏导航到报告单词模板中的书签，并从本机Excel文件中插入每个某些内容或图表。宏在零散运行时起作用，但完全无法执行，Excel一遍又一遍地重复" [IT]正在等待另一个应用程序完成OLE操作。"

为了澄清，宏首先清除了工作簿(其本机文件(中的某个"数据转储"区域，并用指定文件的新数据重新流动。该文件(其位置路径(以及您在代码中看到的各种"目标行"one_answers"标识符"变量被用户输入到一种界面(只是本机工作簿中的工作表(，其中每个界面都被手动标记为一个(命名(范围很容易被送入代码使用。然后，宏通过浏览工作簿的不同表，复制某些内容，然后转到单词以粘贴在书签所指示的模板位置。

来创建报告。

我完全被" OLE错误"所困扰。否则对此/代码有什么想法吗？请分享。感谢您的帮助！

Sub GenerateReport()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim myWorkbook As Excel.Workbook
Set myWorkbook = ThisWorkbook
Dim myWorksheet As Excel.Worksheet
Set myWorksheet = myWorkbook.Sheets("Sheet1")
Dim myWorksheet2 As Excel.Worksheet
Set myWorksheet2 = myWorkbook.Sheets("Sheet2")
Dim myWorksheet3 As Excel.Worksheet
Set myWorksheet3 = myWorkbook.Sheets("Sheet3")
Dim FileName As String
FileName = myWorksheet.Range("FileName")
Dim FilePath As String
FilePath = myWorksheet.Range("FilePath")
Dim TargetSheetName As String
TargetSheetName = myWorksheet.Range("TargetSheetName")
Dim PasteSheetName As String
PasteSheetName = myWorksheet.Range("PasteSheetName")
Dim Identifier As String
Identifier = myWorksheet.Range("Identifier")
Dim Identifier2 As String
Identifier2 = myWorksheet.Range("Identifier2")
Dim TargetRow As String
TargetRow = myWorksheet.Range("TargetRow")
Dim TargetRow2 As String
TargetRow2 = myWorksheet.Range("TargetRow2")
Dim PasteIdentifier As String
PasteIdentifier = myWorksheet.Range("PasteIdentifier")
Dim PasteIdentifier2 As String
PasteIdentifier2 = myWorksheet.Range("PasteIdentifier2")
Dim PasteTargetRow As String
PasteTargetRow = myWorksheet.Range("PasteTargetRow")
Dim PasteTargetRow2 As String
PasteTargetRow2 = myWorksheet.Range("PasteTargetRow2")
Dim Text As String
Text = myWorksheet.Range("Text")
Dim Text2 As String
Text2 = myWorksheet.Range("Text2")
Dim Text3 As String
Text3 = myWorksheet.Range("Text3")
Dim ReportTemplateFilePath As String
ReportTemplateFilePath = myWorksheet.Range("ReportTemplateFilePath")
Dim ReportTemplateFileName As String
ReportTemplateFileName = myWorksheet.Range("ReportTemplateFileName")
Dim SaveToLocation As String
SaveToLocation = myWorksheet.Range("SaveToLocation")
Dim SourceTargetSheet As Excel.Worksheet
Set SourceTargetSheet = myWorkbook.Sheets(PasteSheetName)
Dim TargetWorkbook As Excel.Workbook
Set TargetWorkbook = Workbooks.Open(FilePath)
Dim TargetSheet As Excel.Worksheet
Set TargetSheet = TargetWorkbook.Sheets(TargetSheetName)
'Clear old info
Dim UpperLeftHandCornerOfClear As String
UpperLeftHandCornerOfClear = "A" & PasteTargetRow
Dim LowerRightHandCornerOfClear As String
LowerRightHandCornerOfClear = "XFD" & PasteTargetRow2
SourceTargetSheet.Range(UpperLeftHandCornerOfClear, LowerRightHandCornerOfClear).ClearContents
'Copy new info for pasting
Dim StartingColumnAsRange As Range
Set StartingColumnAsRange = TargetSheet.Cells.Find(Identifier, LookIn:=xlValues, LookAt:=xlPart)
If Not StartingColumnAsRange Is Nothing Then
    Dim StartingColumn As String
    StartingColumn = Split(StartingColumnAsRange.Address, "$")(1)
End If
Dim EndingColumnAsRange As Range
Set EndingColumnAsRange = TargetSheet.Cells.Find(Identifier2, LookIn:=xlValues, LookAt:=xlPart)
If Not EndingColumnAsRange Is Nothing Then
    Dim EndingColumn As String
    EndingColumn = Split(EndingColumnAsRange.Address, "$")(1)
End If
Dim UpperLeftHandCornerOfCopy As String
UpperLeftHandCornerOfCopy = StartingColumn & TargetRow
Dim LowerRightHandCornerOfCopy As String
LowerRightHandCornerOfCopy = EndingColumn & TargetRow2
TargetSheet.Range(UpperLeftHandCornerOfCopy, LowerRightHandCornerOfCopy).Copy
Dim PastePasteTarget As String
PastePasteTarget = "A" & PasteTargetRow
SourceTargetSheet.Range(PastePasteTarget).PasteSpecial Paste:=xlPasteValues
'Create a Microsoft Word object (instance of Word to control)
Dim WordApplication As Word.Application
Set WordApplication = CreateObject("Word.Application")
'Error handle if Microsoft Word is open
On Error Resume Next
    Set WordApplication = GetObject(class:="Word.Application")
    Err.Clear
    If WordApplication Is Nothing Then
        Set WordApplication = CreateObject(class:="Word.Application")
    End If
On Error GoTo 0
'Error handle if report template is specifically already open
On Error Resume Next
Application.DisplayAlerts = False
Documents(ReportTemplateFileName).Close SaveChanges:=wdDoNotSaveChanges
On Error GoTo 0
Application.DisplayAlerts = True
Dim WordDocument As Word.Document
Set WordDocument = WordApplication.Documents.Open(ReportTemplateFilePath)
'Content from 'myWorksheet'
With WordDocument
    .Bookmarks("Bookmark1").Range.Text = myWorksheet.Range("Text1")
    .Bookmarks("Bookmark2").Range.Text = myWorksheet.Range("Text2")
    .Bookmarks("Bookmark3").Range.Text = myWorksheet.Range("Text3")
    .Bookmarks("Bookmark4").Range.Text = myWorksheet.Range("Text4")
End With
'Content from 'myWorksheet2'
With WordDocument
    .Bookmarks("Bookmark5").Range.Text = myWorksheet2.Range("Text5")
    .Bookmarks("Bookmark6").Range.Text = myWorksheet2.Range("Text6")
    .Bookmarks("Bookmark7").Range.Text = myWorksheet2.Range("Text7")
    .Bookmarks("Bookmark8").Range.Text = myWorksheet2.Range("Text8")
    .Bookmarks("Bookmark9").Range.Text = myWorksheet2.Range("Text9")
    .Bookmarks("Bookmark10").Range.Text = myWorksheet3.Range("Text10")
End With
'Chart (alone on worksheet)
WordApplication.Selection.Goto What:=wdGoToBookmark, Name:="Chart1"
ThisWorkbook.Sheets("Chart 1 Worksheet Name").ChartObjects(1).Copy
WordApplication.Selection.Paste
WordApplication.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
'Two charts grouped together
WordApplication.Selection.Goto What:=wdGoToBookmark, Name:="Chart2"
ThisWorkbook.Sheets("Chart 2 Worksheet Name").ChartObjects(1).Copy
WordApplication.Selection.Paste
WordApplication.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
With WordDocument
    .SaveAs FileName:=SaveToLocation & " " & Text3, _
            FileFormat:=wdFormatDocumentDefault
    .Close
End With
WordApplication.Quit
Set WordApplication = Nothing
Set WordDocument = Nothing
Application.ScreenUpdating = True
'Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
myWorksheet.Activate
MsgBox "Report successfully generated.", vbInformation, "Completed!"
End Sub

Answer 1

尝试修改您的单词应用程序创建脚本 - 这就是您所需要的：

On Error Resume Next
Set WordApplication = GetObject(class:="Word.Application")
On Error GoTo 0
If WordApplication Is Nothing Then
    Set WordApplication = CreateObject(class:="Word.Application")
End If

可能是在等待您的某些输入，但您没有看到它，因为您没有使实例可见，所以请尝试添加：

WordApplication.Visible = True