下标超出范围错误-VBA

Question

I am trying to copy and paste multiple tables from excel to word but it's giving me Subscript out of range error when I am trying to define tbl. I found the codes online and is trying to modify the codes to suit my needs.

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

The code I had originally provided was based on your original model, in which the corresponding Worksheet, Table, and Bookmark in each set had a different name.

Now that you have ensured that the names of the objects in each set are identical (which is a better model), try the following procedure. The only difference is that the Scripting.Dictionary has been eliminated, and the Worksheet name is being used to provide both the name of the Table and the name of the Bookmark (since all three values match now).

As before, this one has also been tested in Excel/Word 2016, and is functioning as expected:

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

If you still receive the same error, then perhaps the Workbook is corrupted. In that case, try doing the following:

1. Create a new Workbook with one Worksheet
2. Rename the Worksheet so that its name matches the name of one of the Bookmarks in the Word document
3. Manually add a single, small, "testing-only" Table to the Worksheet (do not copy/paste one from the original Workbook)
4. Ensure that the Table's name is the same as the Worksheet's name
5. Copy/paste the above procedure into a new Module in that Workbook
6. Save the new Workbook
7. Ensure your Word document is open, and run the procedure

If that works, then you might consider recreating your entire original Workbook in the new Workbook. When doing so, if your datasets are large enough that you must copy/paste from the Original Workbook, use "Paste Special" with "Values Only" instead of just a normal Paste. Then, re-create any missing formatting manually. That way, it will be less likely that any corruption in the original Workbook will be transferred to the new one.

Answer 2

Below will copy the first Table in every worksheet and paste into Word doc, regardless of the Table Name. The bookmark names in the Word doc assumed to be simply start at 1 with prefix "bookmark".

If specific Table names are really required, then create a Collection for the names, and loop through each Table in each Worksheet, if that table name is in the Collection then proceed to copy.

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