下標超出範圍錯誤 - 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文檔，無論是表名。在Word文檔中的書籤名稱假設是簡單地在1前綴「書籤」的開始。

如果真的需要特定的表名，然後通過在每個工作表中的每個表創建一個名稱的收集和循環，如果表名是在收集然後進行復制。

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