下標超出范圍錯誤-VBA

Question

我正在嘗試將多個表格從excel復制並粘貼到word，但是當我嘗試定義tbl時，它給我下標超出范圍錯誤。 我在網上找到了代碼，並試圖修改代碼以適合我的需求。

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

如果您仍然收到相同的錯誤，則可能是工作簿已損壞。 在這種情況下，請嘗試執行以下操作：

1. 用一個工作表創建一個新的工作簿
2. 重命名工作表，使其名稱與Word文檔中的其中一個書簽的名稱匹配
3. 手動向工作表中添加一個小的“僅測試”表（不要從原始工作簿中復制/粘貼一個表）
4. 確保表的名稱與工作表的名稱相同
5. 將以上過程復制/粘貼到該工作簿中的新模塊中
6. 保存新的工作簿
7. 確保您的Word文檔已打開，然后運行該過程

如果可行，那么您可以考慮在新工作簿中重新創建整個原始工作簿。 這樣做時，如果您的數據集足夠大， 必須從原始工作簿中復制/粘貼，則將“選擇性粘貼”與“僅值”一起使用，而不僅僅是普通的粘貼。 然后，手動重新創建任何缺少的格式。 這樣，原始工作簿中的任何損壞都不會轉移到新工作簿中的可能性較小。

Answer 2

下面將復制每個工作表中的第一個表並粘貼到Word doc中，而不管表名如何。 Word文檔中的書簽名稱假定簡單地從1開始，並帶有前綴“ bookmark”。

如果確實需要特定的表名，則為這些名稱創建一個集合，並遍歷每個工作表中的每個表，如果該表名在集合中，則繼續進行復制。

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