将所选 Word 表格复制到 Excel
Copy selection of Word tables to Excel
我修改了 Macro to export MS Word tables to Excel sheets 中的代码，以复制表格的顺序间隔（例如 1 到 4），而不是像原始代码那样复制所有表格。
但我不知道如何复制 Word 文档中的部分表格（例如表格 1、3、7、8）。
非常感谢帮助调整相关代码部分！
'For tableStart = 1 To tableTo '<- copies all tables
For tableStart = 1 To 4 '<- copies sequential interval of tables
With .tables(tableStart)
.Range.Copy
Target.Activate
Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'ActiveSheet.Paste <- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Next tableStart
整个宏是：
Sub ImportWordTables()
Dim WordApp As Object
Dim WordDoc As Object
Dim arrFileList As Variant, FileName As Variant
Dim tableNo As Integer 'table number in Word
Dim tableStart As Integer
Dim tableTot As Integer
Dim Target As Range
On Error Resume Next
arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse for file containing table to be imported", , True)
If Not IsArray(arrFileList) Then Exit Sub '<-user cancelled import file browser
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Range("A:AZ").ClearContents
Set Target = Worksheets("MySheet").Range("A1")
For Each FileName In arrFileList
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
With WordDoc
tableNo = WordDoc.tables.Count
tableTot = WordDoc.tables.Count
If tableNo = 0 Then
MsgBox WordDoc.Name & "Contains no tables", vbExclamation, "Import Word Table"
End If
'For tableStart = 1 To tableTo '<- copies all tables
For tableStart = 1 To 4 '<- copies interval of tables
With .tables(tableStart)
.Range.Copy
Target.Activate
Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'ActiveSheet.Paste <- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Next tableStart
.Close False
End With
Next FileName
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
您可以将 table 的列表作为数组提供。我将其添加到下面的重组代码中。您提供一个变体，其中包含要复制到 ImportWordTables 子项的 table 个数字的数组。我会留给您修改代码，将参数设为可选，这样您就可以复制列表中的所有 table 或 table。
Option Explicit
Public Enum TableImportError
NoTables
UnexpectedIndex
End Enum
Public Sub ImportWordTables(ByVal ipTableList As Variant)
Dim arrFileList As Variant
If Not TryGetFileNameList(arrFileList) Then Exit Sub
Dim WordApp As Object
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
' the range should be qualified by the relevant wb/ws
Range("A:AZ").ClearContents
Dim FileName As Variant
For Each FileName In arrFileList
Dim WordDoc As Object
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
Dim myReason As TableImportError
If Not TryImportTables(WordDoc, ipTableList, myReason) Then
Select Case myReason
Case TableImportError.NoTables
MsgBox WordDoc.Name & "Contains no tables", vbExclamation, "Import Word Table"
Case TableImportError.UnexpectedIndex
MsgBox WordDoc.Name & "Unexpected index", vbExclamation, "The table indexes exceed the total table count. No tables copies"
End Select
End If
Next FileName
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
Private Function TryGetFileNameList(ByRef opFileList As Variant) As Boolean
On Error Resume Next
opFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse for file containing table to be imported", , True)
On Error GoTo 0
TryGetFileNameList = IsArray(opFileList)
End Function
Private Function TryImportTables(ByRef ipDoc As Word.Document, ByVal ipTableList As Variant, ByRef opReason As TableImportError) As Boolean
TryImportTables = False
If ipDoc.Tables.Count = 0 Then
opReason = TableImportError.NoTables
Exit Function
End If
Dim myTable As Variant
For Each myTable In ipTableList
If myTable > ipDoc.Tables.Count Then
opReason = TableImportError.UnexpectedIndex
Exit Function
End If
Next
For Each myTable In ipTableList
With ipDoc.Tables.Item(myTable)
.Range.Copy
' replaced Target by worksheet refernce
' ideally this item should be passed as a parameter
' or second best defined as a module level variable.
'
' worksheets should be qualified by the relevant wb
With Worksheets("MySheet")
.Activate
.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
Set .Range("A1") = .Range("A1").Offset(.Rows.Count + 2, 0)
'.Paste
End With
End With
Next
TryImportTables = True
End Function
上面的代码可以编译，并且不会通过用于 VBA 的免费且出色的 Rubberduck 插件给出任何意外的代码检查警告。然而，由于它是一个彻底的重组，我不能保证它会像你以前的代码一样工作，所以请检查你是否决定使用它。
将您的这段代码设置为您使用 TableIndex 从 Main Sub 调用的函数
With .tables(tableIndex)
.Range.Copy
Target.Activate
Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'ActiveSheet.Paste <- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
将 tableIndex 变量设置为从 Word 文档中的 table 集合中分配的随机数。您必须决定迭代代码的次数，以便获得所需的随机样本大小，但基本代码可能如下所示：
Sub ReturnRandomNumber()
Dim TableIndex As Integer
Dim WordDoc As Word.Document
Randomize
TableIndex = Int((WordDoc.Tables.Count * Rnd) + 1)
CopyRandomTable WordDoc, TableIndex
End Sub
Function CopyRandomTable(ByRef WordDoc As Word.Document, ByRef TableIndex As Integer)
With WordDoc.Tables(TableIndex)
.Range.Copy
Target.Activate
Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'ActiveSheet.Paste <- pastes with formatting
Set Target = Target.Offset(.rows.Count + 2, 0)
End With
End Function
RND 函数也可能 return 相同的 table 索引，因此您应该考虑如何处理它...比如可能设置一个 table 索引已被使用，然后采取相应行动。
有关随机化和 RND 函数的更多信息，请点击此处 Microsoft Article on the RND Function。
已解决，但输入框和内存容量问题仍待解决。
将上面第一个示例中的 With .tables(tableIndex) 部分替换为以下内容：
'For array
Dim tables() As Variant
Dim tableCounter As Long
tables = Array(1, 3, 7) '<- define array manually here
For tableCounter = LBound(tables) To UBound(tables)
With .tables(tables(tableCounter))
.Range.Copy
Target.Activate
'Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False '<- gives RAM capacity problems!
ActiveSheet.Paste '<- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Next tableCounter
我修改了 Macro to export MS Word tables to Excel sheets 中的代码，以复制表格的顺序间隔（例如 1 到 4），而不是像原始代码那样复制所有表格。
但我不知道如何复制 Word 文档中的部分表格（例如表格 1、3、7、8）。
非常感谢帮助调整相关代码部分！
'For tableStart = 1 To tableTo '<- copies all tables
For tableStart = 1 To 4 '<- copies sequential interval of tables
With .tables(tableStart)
.Range.Copy
Target.Activate
Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'ActiveSheet.Paste <- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Next tableStart
整个宏是：
Sub ImportWordTables()
Dim WordApp As Object
Dim WordDoc As Object
Dim arrFileList As Variant, FileName As Variant
Dim tableNo As Integer 'table number in Word
Dim tableStart As Integer
Dim tableTot As Integer
Dim Target As Range
On Error Resume Next
arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse for file containing table to be imported", , True)
If Not IsArray(arrFileList) Then Exit Sub '<-user cancelled import file browser
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Range("A:AZ").ClearContents
Set Target = Worksheets("MySheet").Range("A1")
For Each FileName In arrFileList
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
With WordDoc
tableNo = WordDoc.tables.Count
tableTot = WordDoc.tables.Count
If tableNo = 0 Then
MsgBox WordDoc.Name & "Contains no tables", vbExclamation, "Import Word Table"
End If
'For tableStart = 1 To tableTo '<- copies all tables
For tableStart = 1 To 4 '<- copies interval of tables
With .tables(tableStart)
.Range.Copy
Target.Activate
Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'ActiveSheet.Paste <- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Next tableStart
.Close False
End With
Next FileName
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
您可以将 table 的列表作为数组提供。我将其添加到下面的重组代码中。您提供一个变体，其中包含要复制到 ImportWordTables 子项的 table 个数字的数组。我会留给您修改代码，将参数设为可选，这样您就可以复制列表中的所有 table 或 table。
Option Explicit
Public Enum TableImportError
NoTables
UnexpectedIndex
End Enum
Public Sub ImportWordTables(ByVal ipTableList As Variant)
Dim arrFileList As Variant
If Not TryGetFileNameList(arrFileList) Then Exit Sub
Dim WordApp As Object
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
' the range should be qualified by the relevant wb/ws
Range("A:AZ").ClearContents
Dim FileName As Variant
For Each FileName In arrFileList
Dim WordDoc As Object
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
Dim myReason As TableImportError
If Not TryImportTables(WordDoc, ipTableList, myReason) Then
Select Case myReason
Case TableImportError.NoTables
MsgBox WordDoc.Name & "Contains no tables", vbExclamation, "Import Word Table"
Case TableImportError.UnexpectedIndex
MsgBox WordDoc.Name & "Unexpected index", vbExclamation, "The table indexes exceed the total table count. No tables copies"
End Select
End If
Next FileName
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
Private Function TryGetFileNameList(ByRef opFileList As Variant) As Boolean
On Error Resume Next
opFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse for file containing table to be imported", , True)
On Error GoTo 0
TryGetFileNameList = IsArray(opFileList)
End Function
Private Function TryImportTables(ByRef ipDoc As Word.Document, ByVal ipTableList As Variant, ByRef opReason As TableImportError) As Boolean
TryImportTables = False
If ipDoc.Tables.Count = 0 Then
opReason = TableImportError.NoTables
Exit Function
End If
Dim myTable As Variant
For Each myTable In ipTableList
If myTable > ipDoc.Tables.Count Then
opReason = TableImportError.UnexpectedIndex
Exit Function
End If
Next
For Each myTable In ipTableList
With ipDoc.Tables.Item(myTable)
.Range.Copy
' replaced Target by worksheet refernce
' ideally this item should be passed as a parameter
' or second best defined as a module level variable.
'
' worksheets should be qualified by the relevant wb
With Worksheets("MySheet")
.Activate
.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
Set .Range("A1") = .Range("A1").Offset(.Rows.Count + 2, 0)
'.Paste
End With
End With
Next
TryImportTables = True
End Function
上面的代码可以编译，并且不会通过用于 VBA 的免费且出色的 Rubberduck 插件给出任何意外的代码检查警告。然而，由于它是一个彻底的重组，我不能保证它会像你以前的代码一样工作，所以请检查你是否决定使用它。
将您的这段代码设置为您使用 TableIndex 从 Main Sub 调用的函数
With .tables(tableIndex)
.Range.Copy
Target.Activate
Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'ActiveSheet.Paste <- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
将 tableIndex 变量设置为从 Word 文档中的 table 集合中分配的随机数。您必须决定迭代代码的次数，以便获得所需的随机样本大小，但基本代码可能如下所示：
Sub ReturnRandomNumber()
Dim TableIndex As Integer
Dim WordDoc As Word.Document
Randomize
TableIndex = Int((WordDoc.Tables.Count * Rnd) + 1)
CopyRandomTable WordDoc, TableIndex
End Sub
Function CopyRandomTable(ByRef WordDoc As Word.Document, ByRef TableIndex As Integer)
With WordDoc.Tables(TableIndex)
.Range.Copy
Target.Activate
Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
'ActiveSheet.Paste <- pastes with formatting
Set Target = Target.Offset(.rows.Count + 2, 0)
End With
End Function
RND 函数也可能 return 相同的 table 索引，因此您应该考虑如何处理它...比如可能设置一个 table 索引已被使用，然后采取相应行动。
有关随机化和 RND 函数的更多信息，请点击此处 Microsoft Article on the RND Function。
已解决，但输入框和内存容量问题仍待解决。
将上面第一个示例中的 With .tables(tableIndex) 部分替换为以下内容：
'For array
Dim tables() As Variant
Dim tableCounter As Long
tables = Array(1, 3, 7) '<- define array manually here
For tableCounter = LBound(tables) To UBound(tables)
With .tables(tables(tableCounter))
.Range.Copy
Target.Activate
'Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False '<- gives RAM capacity problems!
ActiveSheet.Paste '<- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Next tableCounter