VBA下标超出范围，错误9

I know this error has been defined in earlier posts for e.g. here. I am pretty new to VBA and do not really understand the explanation there.

我知道这个错误在之前的文章中已经有过定义，比如这里。我对VBA很陌生，也不太理解这里的解释。

I am using the following code to automate adding multiple tables to a word document by bookmarking them as explained in the link http://www.thespreadsheetguru.com/blog/2014/10/5/multiple-tables-to-word-with-vba.I am getting a Subscript out of range (error 9)

我正在使用下面的代码通过书签将多个表添加到word文档中，方法是将它们添加到http://www.thespreadsheetguru.com/blog4/2014/10/5/multiple table -to-word-with- vba中。

The tables are created in the same sheet manually by myself by selecting a particular range in the excel sheet.

通过在excel表中选择一个特定的范围，我可以在同一个表中手工创建这些表。

Here below you can find the code. I would really be grateful if someone can identify where I am going wrong.

在下面你可以找到代码。如果有人能指出我哪里做错了，我会非常感激。

Thank you very much in advance.

非常感谢。

---

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

Sub ExcelTablesToWord()

'PURPOSE: Copy/Paste An Excel Table Into a New Word Document
'NOTE: Must have Word Object Library Active in Order to Run _
  (VBE > Tools > References > Microsoft Word 12.0 Object Library)
'SOURCE: www.TheSpreadsheetGuru.com

Dim tbl As Excel.Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Dim TableArray As Variant
Dim BookmarkArray As Variant

'List of Table Names (To Copy)
  TableArray = Array("Table1", "Table2", "Table3", "Table4", "Table5")

'List of Word Document Bookmarks (To Paste To)
  BookmarkArray = Array("Bookmark1", "Bookmark2", "Bookmark3", "Bookmark4", "Bookmark5")

'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("Siko_LEFIS_v0.1.docx")
  On Error GoTo 0

'Loop Through and Copy/Paste Multiple Excel Tables
  For x = LBound(TableArray) To UBound(TableArray)

    'Copy Table Range from Excel

      tbl = ThisWorkbook.Worksheets(x).ListObjects(TableArray(x)).Range  '####Here is where i get the subbscipt out of range error#######
      tbl.Copy

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

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

  Next x

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

'ERROR HANDLER
WordDocNotFound:
  MsgBox "Microsoft Word file 'Siko_LEFIS_v0.1.docx' 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 个解决方案

#1

The code below (some slight tweaks for my environment) worked for me. Most likely cause of your error was that you don't have a table with the expected name on one of your sheets.

下面的代码(对我的环境做了一些微调)对我来说很有用。最可能导致您出错的原因是您没有一个表，其中一个表上没有期望的名称。

You were also missing Set on that line (required when assigning a value to an object variable)

您还丢失了该行中的设置(当为对象变量赋值时需要)

Option Explicit

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

Sub ExcelTablesToWord()

Dim tbl As Excel.Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Dim TableArray As Variant
Dim BookmarkArray As Variant
Dim x As Long, sht As Worksheet


  TableArray = Array("Table1", "Table2")
  BookmarkArray = Array("Bookmark1", "Bookmark2")

  Application.ScreenUpdating = False
  Application.EnableEvents = False

  On Error GoTo WordDocNotFound
    Set WordApp = GetObject(class:="Word.Application")
    WordApp.Visible = True
    Set myDoc = WordApp.Activedocument
    'Set myDoc = WordApp.Documents("Siko_LEFIS_v0.1.docx")
  On Error GoTo 0


  For x = LBound(TableArray) To UBound(TableArray)

      Set sht = ThisWorkbook.Worksheets(x)
      Set tbl = sht.ListObjects(TableArray(x)).Range

      myDoc.Bookmarks(BookmarkArray(x)).Range.PasteExcelTable _
        LinkedToExcel:=False, _
        WordFormatting:=False, _
        RTF:=False

      Set WordTable = myDoc.Tables(x)
      WordTable.AutoFitBehavior (wdAutoFitWindow)

  Next x

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

    'ERROR HANDLER
WordDocNotFound:
      MsgBox "Microsoft Word file 'Siko_LEFIS_v0.1.docx' 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

I would also recommend that you try to avoid using the Option Base 1 setting: it might appear to make dealing with arrays easier, but changing the default array behavior causes more problem than it solves.

我还建议您尽量避免使用选项Base 1设置:它可能会使处理数组变得更容易，但是更改默认的数组行为会导致比它解决的更多的问题。