[英]Subscript out of range error - vba
我正在尝试将多个表格从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
我最初提供的代码是基于您的原始模型的,其中每个集合中相应的工作表,表格和书签具有不同的名称。
现在,您已确保每个集合中的对象名称相同(这是一个更好的模型),请尝试以下过程。 唯一的区别是,已删除了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 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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.