Excel 将所有文本框（包含在每个工作表中）复制到word文档中

我正在尝试将每个工作表内容（文本框和形状，没有单元格内容）导出到word文档中。结果不是我所期望的。如果有两个工作表，每个工作表都有一个文本框，那么一个文本框将被复制两次，而另一个文本框根本不会被复制

Private Sub Export()
Dim WordApp As Word.Application
Set WordApp = CreateObject("Word.Application")
On Error Resume Next
WordApp.Documents.Add
WordApp.Visible = True

For Each ws In ActiveWorkbook.Worksheets
    ws.Shapes.SelectAll
    Selection.Copy

WordApp.Selection.PasteSpecial DataType:=wdPasteShape
Application.CutCopyMode = False

Next ws

End Sub

我缺少的是：

在导出每个ws后插入分页符

了解为什么一个工作表中的文本框被复制两次，而另一个工作表中的文本框根本不被复制

1.添加分页符 如果要在Word文件的结尾插入分页符，可以（1）选择Word内容部分的结尾，并（2）按如下方式插入分页符：

WordApp.Selection.EndKey Unit:=wdStory
WordApp.Selection.InsertBreak

Private Sub Export_v1()
    Dim WordApp As Word.Application
    Set WordApp = CreateObject("Word.Application")
    On Error Resume Next
    WordApp.Documents.Add
    WordApp.Visible = True
    
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ws.Shapes.SelectAll
        Selection.Copy

        WordApp.Selection.PasteSpecial DataType:=wdPasteShape
        Application.CutCopyMode = False
        
        WordApp.Selection.EndKey Unit:=wdStory
        WordApp.Selection.InsertBreak
        
    Next ws

End Sub

Private Sub Export_v2()
    Dim WordApp As Word.Application
    Set WordApp = CreateObject("Word.Application")
    On Error Resume Next
    WordApp.Documents.Add
    WordApp.Visible = True
    
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ws.Activate
        ws.Shapes.SelectAll
        Selection.Copy

        WordApp.Selection.PasteSpecial DataType:=wdPasteShape
        Application.CutCopyMode = False
        
        WordApp.Selection.EndKey Unit:=wdStory
        WordApp.Selection.InsertBreak
        
    Next ws

End Sub

您的代码将如下所示：

WordApp.Selection.EndKey Unit:=wdStory
WordApp.Selection.InsertBreak

Private Sub Export_v1()
    Dim WordApp As Word.Application
    Set WordApp = CreateObject("Word.Application")
    On Error Resume Next
    WordApp.Documents.Add
    WordApp.Visible = True
    
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ws.Shapes.SelectAll
        Selection.Copy

        WordApp.Selection.PasteSpecial DataType:=wdPasteShape
        Application.CutCopyMode = False
        
        WordApp.Selection.EndKey Unit:=wdStory
        WordApp.Selection.InsertBreak
        
    Next ws

End Sub

Private Sub Export_v2()
    Dim WordApp As Word.Application
    Set WordApp = CreateObject("Word.Application")
    On Error Resume Next
    WordApp.Documents.Add
    WordApp.Visible = True
    
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ws.Activate
        ws.Shapes.SelectAll
        Selection.Copy

        WordApp.Selection.PasteSpecial DataType:=wdPasteShape
        Application.CutCopyMode = False
        
        WordApp.Selection.EndKey Unit:=wdStory
        WordApp.Selection.InsertBreak
        
    Next ws

End Sub

---

2.避免粘贴相同的文本框 如果您运行上述宏，您仍然会从第一张工作表中获得两次文本框。为什么？因为您使用的是

选择。复制

，这取决于哪个工作表处于活动状态

要确保正确的工作表处于活动状态，只需添加

ws.Activate

，然后选择如下形状：

WordApp.Selection.EndKey Unit:=wdStory
WordApp.Selection.InsertBreak

Private Sub Export_v1()
    Dim WordApp As Word.Application
    Set WordApp = CreateObject("Word.Application")
    On Error Resume Next
    WordApp.Documents.Add
    WordApp.Visible = True
    
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ws.Shapes.SelectAll
        Selection.Copy

        WordApp.Selection.PasteSpecial DataType:=wdPasteShape
        Application.CutCopyMode = False
        
        WordApp.Selection.EndKey Unit:=wdStory
        WordApp.Selection.InsertBreak
        
    Next ws

End Sub

Private Sub Export_v2()
    Dim WordApp As Word.Application
    Set WordApp = CreateObject("Word.Application")
    On Error Resume Next
    WordApp.Documents.Add
    WordApp.Visible = True
    
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ws.Activate
        ws.Shapes.SelectAll
        Selection.Copy

        WordApp.Selection.PasteSpecial DataType:=wdPasteShape
        Application.CutCopyMode = False
        
        WordApp.Selection.EndKey Unit:=wdStory
        WordApp.Selection.InsertBreak
        
    Next ws

End Sub

---

3.潜在的改进 3.1避免在Excel内部使用Select

可以大大提高速度。但是，在这种情况下，您不能仅仅替换

ws.Shapes.SelectAll
Selection.Copy

与

因为它不会复制形状。相反，您需要遍历工作表中的每个形状，以逐个粘贴它们。这可能会给您的代码带来更多的复杂性，所以如果速度不是问题，您可以保持这样

3.2将对象重置为零

为避免Excel内存不足，最好在使用完对象后（在本例中，在过程结束时）始终将其重置为零：