因此，我尝试将Excel数据库的多列复制并粘贴到Word文档中。每次完成“回合”操作时，它将光标停留在第一个单元格中，因此弄乱了格式。我试图使光标滚动到上一个表之外，以在下面创建一个新表。有问题的代码会在“自动调整表”中指出，因此可以放入Word文档中
我尝试过
Selection.MoveDown Unit:=wdLine, Count:=54
但是它给出了一个错误
这是我的完整代码：
Sub ReportGen()
'ROUND 1
Dim myValue As Variant
Dim atbl As Excel.Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim aWordTable As Word.Table
'Define whos info you need
myValue = InputBox("Who are you meeting with?")
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Copy Range from Excel
Sheets("Stage Gate (Open)").Select
ActiveSheet.Range("$A$6:$AL$25").AutoFilter Field:=3, Criteria1:=myValue
Set atbl = ThisWorkbook.Worksheets("Stage Gate (Open)").Range("C6:C10,a6:a10,b6:b10,e6:e10")
'Create an Instance of MS Word
On Error Resume Next
'Is MS Word already opened?
Set WordApp = GetObject(class:="Word.Application")
'Clear the error between errors
Err.Clear
'If MS Word is not already open then open MS Word
If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
'Handle if the Word Application is not found
If Err.Number = 429 Then
MsgBox "Microsoft Word could not be found, aborting."
GoTo EndRoutine
End If
On Error GoTo 0
'Make MS Word Visible and Active
WordApp.Visible = True
WordApp.Activate
'Create a New Document
Set myDoc = WordApp.Documents.Add
'Copy Excel Table Range
atbl.Copy
'Paste Table into MS Word
myDoc.Paragraphs(1).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit Table so it fits inside Word Document
Set aWordTable = myDoc.Tables(1)
aWordTable.AutoFitBehavior (wdAutoFitWindow)
myDoc.Selection.MoveDown Unit:=wdLine, Count:=54
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
'ROUND 2
Dim btbl As Excel.Range
Dim WordTable As Word.Table
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Copy Range from Excel
Sheets("Stage Gate Support (Open)").Select
ActiveSheet.Range("$A$6:$AL$25").AutoFilter Field:=3, Criteria1:=myValue
Set btbl = ThisWorkbook.Worksheets("Stage Gate Support (Open)").Range("C3:C10,a3:a10,b3:b10,e3:e10")
'Make MS Word Visible and Active
WordApp.Visible = True
WordApp.Activate
'Copy Excel Table Range
btbl.Copy
'Paste Table into MS Word
myDoc.Paragraphs(1).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit Table so it fits inside Word Document
Set bWordTable = myDoc.Tables(1)
bWordTable.AutoFitBehavior (wdAutoFitWindow)
Selection.MoveDown Unit:=wdLine, Count:=54
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
'ROUND 3
Dim ctbl As Excel.Range
Dim cWordTable As Word.Table
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Copy Range from Excel
Sheets("Bermondsey (Open)").Select
ActiveSheet.Range("$A$6:$AL$25").AutoFilter Field:=3, Criteria1:=myValue
Set ctbl = ThisWorkbook.Worksheets("Bermondsey (Open)").Range("C6:C10,a6:a10,b6:b10,e6:e10")
'Make MS Word Visible and Active
WordApp.Visible = True
WordApp.Activate
'Copy Excel Table Range
ctbl.Copy
'Paste Table into MS Word
myDoc.Paragraphs(1).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit Table so it fits inside Word Document
Set cWordTable = myDoc.Tables(1)
cWordTable.AutoFitBehavior (wdAutoFitWindow)
Selection.MoveDown Unit:=wdLine, Count:=54
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
答案 0 :(得分：0)
尝试以下方法。注意，什么都不会被选择，这使代码效率更高。按照编码，每个表都在自己的页面上输出。
Sub ReportGen()
Dim atbl As Range, btbl As Range, As Range
Dim WordApp As Object, myDoc As Object
Dim myValue As Variant
'Define who's info you need
myValue = InputBox("Who are you meeting with?")
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Create an Instance of MS Word
On Error Resume Next
'Is MS Word already opened?
Set WordApp = GetObject(, "Word.Application")
'Clear the error between errors
Err.Clear
'If MS Word is not already open then open MS Word
If WordApp Is Nothing Then Set WordApp = CreateObject("Word.Application")
'Handle if the Word Application is not found
If Err.Number = 429 Then
MsgBox "Microsoft Word could not be found, aborting."
GoTo EndRoutine
End If
On Error GoTo 0
'Make MS Word Visible and Active
WordApp.Visible = True
'Set Excel Ranges
With Sheets("Stage Gate (Open)")
.Range("$A$6:$AL$25").AutoFilter Field:=3, Criteria1:=myValue
Set atbl = .Range("C6:C10,a6:a10,b6:b10,e6:e10")
Set btbl = .Range("C3:C10,a3:a10,b3:b10,e3:e10")
End With
With Sheets("Bermondsey (Open)")
.Range("$A$6:$AL$25").AutoFilter Field:=3, Criteria1:=myValue
Set ctbl = .Range("C6:C10,a6:a10,b6:b10,e6:e10")
End With
'Create a New Document
Set myDoc = WordApp.Documents.Add
With myDoc
'Copy Excel Table Range
atbl.Copy
'Paste Table into MS Word
.Range.Characters.Last.PasteExcelTable False, False, False
'Autofit Table so it fits inside Word Document
.Tables(1).AutoFitBehavior 2 'wdAutoFitWindow
.Range.InsertAfter Chr(12)
'Copy Excel Table Range
btbl.Copy
'Paste Table into MS Word
.Range.Characters.Last.PasteExcelTable False, False, False
'Autofit Table so it fits inside Word Document
.Tables(2).AutoFitBehavior 2 'wdAutoFitWindow
.Range.InsertAfter Chr(12)
ctbl.Copy
'Paste Table into MS Word
.Range.Characters.Last.PasteExcelTable False, False, False
'Autofit Table so it fits inside Word Document
.Tables(3).AutoFitBehavior 2 'wdAutoFitWindow
End With
Set atbl = Nothing: Set btbl = Nothing: Set ctbl = Nothing
Set myDoc = Nothing: Set WordApp = Nothing
EndRoutine:
'Clear The Clipboard
Application.CutCopyMode = False
'Optimize Code
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub