从Excel应用程序生成Microsoft Word报告等待OLE操作? (VBA)

时间:2017-06-07 15:23:40

标签: vba excel-vba ms-word ole excel

我正在尝试编写一个可以从Excel文件生成Microsoft Word“报告”的宏。我希望宏能够导航到报表的Word模板中的书签,并插入每个特定内容或本机Excel文件中的图表。该宏在零碎运行时起作用,但完全无法执行,Excel反复重复“[It]正在等待另一个应用程序完成OLE操作。”

为了澄清,宏首先清除工作簿中的某个“数据转储”区域(其本机文件),并使用指定文件中的新数据重新填充它。您在代码中看到的此文件(其位置路径)和各种“目标行”和“标识符”变量由用户输入到某种界面(只是本机工作簿中的工作表),其中每个都手动标记为一个(命名的)范围很容易被输入以供代码使用。宏然后通过浏览工作簿的不同工作表,复制某些内容,并转到Word将复制的内容粘贴到书签指示的模板位置来创建报告。

我对'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

1 个答案:

答案 0 :(得分:0)

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

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

可能是Word正在等待您的某些输入但是您没有看到它,因为您没有让实例可见,所以请尝试添加:

WordApplication.Visible = True