在 word 中复制和粘贴现有表格并继续编号 (VBA)

如何解决在 word 中复制和粘贴现有表格并继续编号 (VBA)

我编写了一个 VBA 脚本，用于复制整个 Word 文档（其中有多个表格，最左边的列有一个编号列表）并将其粘贴到 Word 文档的末尾。然后脚本再次从“1”重新启动编号列表。

当我从执行所有复制/粘贴的 word 文档中运行它时，我的脚本运行良好 - 但是当我从一个单独的 word 文档中运行它时它不起作用，该文档遍历一个充满 word 文档的文件夹.

首先，这里是实际工作的脚本：

Sub copyAndPasteEntireDocument()

    Dim TotalNumberOfTables As Integer

    ' save the total number of tables in this document
    TotalNumberOfTables = ActiveDocument.Tables.Count

    ' copy and paste the whole document (so it is duplicated)
    With Selection
        .WholeStory
        .copy
        .EndKey Unit:=wdStory
        .InsertBreak Type:=wdPageBreak
        .Paste
    End With
    
    ' Restart the numbering of the new tables (that were just pasted) from number 1
    Listgalleries(wdNumbergallery).ListTemplates(1).ListLevels(1).StartAt = 1
    ActiveDocument.Tables(TotalNumberOfTables + 1).Cell(2,1).Select
    
    ' this next line is where the document hangs
    Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
        Listgalleries(wdNumbergallery).ListTemplates(1),ContinuePrevIoUsList:= _
        False,ApplyTo:=wdListApplyToWholeList,DefaultListBehavior:= _
        wdWord10ListBehavior
        
    ' Fix up the formatting of the first number in the new list (which is in the second row by copying the formatting info from the third row)
    ActiveDocument.Tables(TotalNumberOfTables + 1).Cell(3,1).Select
    Selection.copyFormat
    ActiveDocument.Tables(TotalNumberOfTables + 1).Cell(2,1).Select
    Selection.PasteFormat
End Sub

当我修改代码以遍历包含多个文档的文件夹时，除了试图从“1”重新启动编号列表的行外，一切正常。代码如下：

Sub copyAndPasteEntireDocumentFromFolder()
    Dim TotalNumberOfTables As Integer  ' used to store the number of tables in the document before duplicating everything
    Dim FName As String
    Dim FilePath As String
    Dim wrd As Word.Application
    Set wrd = CreateObject("word.application")
    wrd.Visible = True
    
    ' open a dialog Box allowing the user to select a folder containing the word documents
    FilePath = GetFolder
    
    ' Find all .docx files in our filepath
    FName = Dir(FilePath & "*.docx")
    
    ' open and edit each file in that folder
    do while (FName <> "")
        With wrd
            ' Open the next document in the folder
            .Documents.Open (FilePath & FName)
            
            ' save the total number of tables in this document
            TotalNumberOfTables = ActiveDocument.Tables.Count

            ' copy and paste the whole document (so it is duplicated)
            With .Selection
                .WholeStory
                .copy
                .EndKey Unit:=wdStory
                .InsertBreak Type:=wdPageBreak
                .Paste
            End With
            
            ' Restart the numbering of the new tables (that were just pasted) from number 1
            .Listgalleries(wdNumbergallery).ListTemplates(1).ListLevels(1).StartAt = 1
            .ActiveDocument.Tables(TotalNumberOfTables + 1).Cell(2,1).Select
            
            ' this next line is where the document hangs
            .Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
                Listgalleries(wdNumbergallery).ListTemplates(1),ContinuePrevIoUsList:= _
                False,DefaultListBehavior:= _
                wdWord10ListBehavior
                
            ' Fix up the formatting of the first number in the new list (which is in the second row by copying the formatting info from the third row)
            .ActiveDocument.Tables(TotalNumberOfTables + 1).Cell(3,1).Select
            .Selection.copyFormat
            .ActiveDocument.Tables(TotalNumberOfTables + 1).Cell(2,1).Select
            .Selection.PasteFormat
            
            ' save and close the document
            .ActiveDocument.SaveAs FileName:=FilePath & FName
            
            .ActiveDocument.Save
            .ActiveDocument.Close
        End With
        FName = Dir
    Loop
    Set wrd = nothing
End Sub

Function GetFolder() As String
    ' this routine opens a file dialog to allow the user to select which folder they want to load .docx files from
    
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
    
    ' Finally,we add one last backslash to the path
    sItem = sItem & "\"
    
NextCode:
    GetFolder = sItem
    Set fldr = nothing
End Function

任何人都可以提供有关为什么在文档中运行时可以正常工作但从文件夹中打开文档时可以正常工作的任何见解吗？