Question

我正在尝试将多个表从excel复制并粘贴到word，但是当我尝试定义tbl时，它会让我的Subscript超出范围错误。我在网上找到了这些代码，并试图修改代码以满足我的需求。

Sub ExcelTablesToWord_Modified()

    Dim WordApp As Word.Application
    Dim myDoc As Word.Document
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim sheet As Excel.Worksheet
    Dim tableName As String

    With dict
        .Add "TableA1", "TableA1"
        .Add "TableA2", "TableA2"
        .Add "TableB1", "TableB1"
        .Add "TableB2", "TableB2"
        .Add "TableC", "TableC"
        .Add "TableD", "TableD"
        .Add "TableE1", "TableE1"
        .Add "TableE2", "TableE2"
        .Add "TableF1", "TableF1"
        .Add "TableF2", "TableF2"
        'TODO: add the remaining WorksheetName/TableName combinations
    End With

    'Optimize Code
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    'Set Variable Equal To Destination Word Document
    On Error GoTo WordDocNotFound
      Set WordApp = GetObject(class:="Word.Application")
      WordApp.Visible = True
      Set myDoc = WordApp.Documents("a.docx")
    On Error GoTo 0

    'Loop Through Worksheets, and Copy/Paste Multiple Excel Tables
    For Each sheet In ActiveWorkbook.Worksheets
        tableName = dict(sheet.Name)

        'Copy Table Range from Excel
        sheet.ListObjects(tableName).Range.Copy

        'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
        myDoc.Bookmarks(tableName).Range.PasteExcelTable _
            LinkedToExcel:=False, _
            WordFormatting:=False, _
            RTF:=False

        'Autofit the most-recently-pasted Table so it fits inside Word Document
        myDoc.Tables(myDoc.Tables.Count).AutoFitBehavior (wdAutoFitWindow)

    Next sheet

    'Completion Message
    MsgBox "Copy/Pasting Complete!", vbInformation
    GoTo EndRoutine

    'ERROR HANDLER
WordDocNotFound:
    MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16

    'Put Stuff Back The Way It Was Found
EndRoutine:
    'Optimize Code
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    'Clear The Clipboard
    Application.CutCopyMode = False

End Sub

Answer 1

我最初提供的代码基于您的原始模型，其中每个集合中相应的工作表，表格和书签具有不同的名称。

现在您已确保每组中对象的名称相同（这是一个更好的模型），请尝试以下过程。唯一的区别是Scripting.Dictionary已被删除，并且工作表名称用于提供表的名称和书签的名称（因为现在所有三个值都匹配）。

和以前一样，这个也已经在Excel / Word 2016中测试过，并且按预期运行：

Public Sub ExcelTablesToWord_Modified2()

    Dim WordApp As Word.Application
    Dim myDoc As Word.Document
    Dim sheet As Excel.Worksheet

    'Optimize Code
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    'Set Variable Equal To Destination Word Document
    On Error GoTo WordDocNotFound
      Set WordApp = GetObject(class:="Word.Application")
      WordApp.Visible = True
      Set myDoc = WordApp.Documents("a.docx")
    On Error GoTo 0

    'Loop Through Worksheets, and Copy/Paste Multiple Excel Tables
    For Each sheet In ActiveWorkbook.Worksheets

        'Copy Table Range from Excel
        sheet.ListObjects(sheet.Name).Range.Copy

        'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
        myDoc.Bookmarks(sheet.Name).Range.PasteExcelTable _
            LinkedToExcel:=False, _
            WordFormatting:=False, _
            RTF:=False

        'Autofit the most-recently-pasted Table so it fits inside Word Document
        myDoc.Tables(myDoc.Tables.Count).AutoFitBehavior (wdAutoFitWindow)

    Next sheet

    'Completion Message
    MsgBox "Copy/Pasting Complete!", vbInformation
    GoTo EndRoutine

    'ERROR HANDLER
WordDocNotFound:
    MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16

    'Put Stuff Back The Way It Was Found
EndRoutine:
    'Optimize Code
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    'Clear The Clipboard
    Application.CutCopyMode = False

End Sub

如果仍然收到相同的错误，则可能是工作簿已损坏。在这种情况下，请尝试执行以下操作：

使用一个工作表创建一个新工作簿
重命名工作表，使其名称与Word文档中的一个书签的名称相匹配
手动在工作表中添加一个小的“仅限测试”表（不要复制/粘贴原始工作簿中的一个）
确保表的名称与工作表的名称相同
将上述程序复制/粘贴到该工作簿中的新模块
保存新工作簿
确保Word文档已打开，然后运行

如果可以，那么您可以考虑在新工作簿中重新创建整个原始工作簿。执行此操作时，如果您的数据集足够大，以至于必须从原始工作簿中复制/粘贴，请使用“仅限值粘贴”，而不是仅使用普通粘贴。然后，手动重新创建任何缺少的格式。这样，原始工作簿中的任何损坏都不太可能转移到新工作簿中。

Answer 2

下面将复制每个工作表中的第一个表并粘贴到Word文档中，而不管表名是什么。假设Word doc中的书签名称只是从1开始，前缀为“bookmark”。

如果确实需要特定的表名，则为名称创建一个Collection，并遍历每个工作表中的每个表，如果该表名在Collection中，则继续复制。

Option Base 1 'Force arrays to start at 1 instead of 0

Sub ExcelTablesToWord()

    Dim oWS As Worksheet
    Dim tbl As Excel.Range
    Dim WordApp As Object ' Word.Application
    Dim myDoc As Object ' Word.Document
    Dim x As Long ' Integer


    'Optimize Code
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    'Set Variable Equal To Destination Word Document
    On Error Resume Next
    Set WordApp = GetObject(, "Word.Application")
    If WordApp Is Nothing Then Set WordApp = CreateObject("Word.Application")
    If WordApp Is Nothing Then GoTo WordDocNotFound
    WordApp.Visible = True
    Set myDoc = WordApp.Documents("a.docx")
    If myDoc Is Nothing Then Set myDoc = WordApp.Documents.Open("a.docx")
    If myDoc Is Nothing Then GoTo WordDocNotFound

    'Loop Through and Copy/Paste Multiple Excel Tables
    x = 1 ' For x = LBound(TableArray) To UBound(TableArray)
    For Each oWS In ThisWorkbook.Worksheets

        'Copy Table Range from Excel
        'Set tbl = ThisWorkbook.Worksheets(x).ListObjects(TableArray(x)).Range
        Set tbl = oWS.ListObjects(1).Range
        If Not tbl Is Nothing Then
            tbl.Copy

            'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
            myDoc.Bookmarks("bookmark" & x).Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False

            'Autofit Table so it fits inside Word Document
            myDoc.Tables(x).AutoFitBehavior 2 ' (wdAutoFitWindow)

            x = x + 1
        End If
    Next
    On Error GoTo 0

    'Completion Message
    MsgBox "Copy/Pasting Complete!", vbInformation
    GoTo EndRoutine

    'ERROR HANDLER
WordDocNotFound:
    MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16

    'Put Stuff Back The Way It Was Found
EndRoutine:
    'Optimize Code
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    'Clear The Clipboard
    Application.CutCopyMode = False

End Sub

下标超出范围错误 - vba

2 个答案: