将多个工作表粘贴到一个Word文档中

我试图将工作簿中的每个工作表复制并粘贴到单个Word文档中的新工作表中。 不幸的是，它只是复制了第一个工作表的内容，尽pipe它似乎在循环所有的工作表。 我认为插入分页符将工作，但事实并非如此。 它也不会让我在Word中格式化。 我想要A1的内容有一个标题样式。

这是我的代码：

Sub ExceltoWord() Dim ws As Worksheet Dim Wkbk1 As Workbook Set Wkbk1 = ActiveWorkbook Application.ScreenUpdating = False Application.DisplayAlerts = False Application.EnableEvents = False For Each ws In Wkbk1.Worksheets Wkbk1.ActiveSheet.Range("A1:A2").Copy Dim wdapp As Object Dim wddoc As Object Dim Header As Range 'file name & folder path Dim strdocname As String On Error Resume Next 'error number 429 Set wdapp = GetObject(, "Word.Application") If Err.Number = 429 Then Err.Clear 'create new instance of word application Set wdapp = CreateObject("Word.Application") End If wdapp.Visible = True 'define paths to file strdocname = "P:\ImportedDescriptions.doc" If Dir(strdocname) = "" Then MsgBox "The file" & strdocname & vbCrLf & "was not found " & vbCrLf & "P:\ImportedDescriptions.doc", vbExclamation, "The document does not exist " Exit Sub End If wdapp.Activate Set wddoc = wdapp.Documents(strdocname) If wddoc Is Nothing Then Set wddoc = wdapp.Documents.Open(strdocname) Set Header = Range("A1") 'must activate to be able to paste wddoc.Activate wddoc.Range.Paste Selection.WholeStory Header.Style = ActiveDocument.Styles("Heading 2") Selection.InsertBreak Type:=wdPageBreak Next ws wddoc.Save 'wdapp.Quit Set wddoc = Nothing Set wdapp = Nothing Application.ScreenUpdating = True Application.DisplayAlerts = True Application.EnableEvents = True End Sub 

Answer 1

您只能从活动工作表中复制，而这恰好是您的案例中的第一个工作表。 代替：

 For Each ws In ActiveWorkbook.Worksheets ActiveWorkbook.ActiveSheet.Range("A1:A2").Copy 

使用：

 For Each ws In ActiveWorkbook.Worksheets ws.Range("A1:A2").Copy 

这将依次复制每个范围。

Answer 2

我认为，当您激活Word时，您正在开始使用哪个工作簿。 将工作簿保存到工作簿variables（即Dim Wkbk1 As Workbook ， Set Wkbk1 = ActiveWorkbook ），然后用Set Wkbk1 = ActiveWorkbookreplace代码中的ActiveWorkbook的每个实例（在For Each循环中，每当您想在循环内引用它时好）。