[英]Preserve formatting of Word table in Excel VBA
在另一个讨论中,我能够找到此宏,该宏将Word中的表导入Excel。
它很好用,但是如何使它保持Word表的格式呢?
我尝试了几种方法,但无法完全正常工作。 还有一种方法可以一次处理更多文件,而不是一次处理多个文件吗?
Option Explicit
Sub ImportWordTable()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim resultRow As Long
Dim tableStart As Integer
Dim tableTot As Integer
On Error Resume Next
ActiveSheet.Range("A:AZ").ClearContents
wdFileName = Application.GetOpenFilename("Word files (*.doc),*.doc", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
tableNo = wdDoc.tables.Count
tableTot = wdDoc.tables.Count
If tableNo = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
ElseIf tableNo > 1 Then
tableNo = InputBox("This Word document contains " & tableNo & " tables." & vbCrLf & _
"Enter the table to start from", "Import Word Table", "1")
End If
resultRow = 4
For tableStart = 1 To tableTot
With .tables(tableStart)
'copy cell contents from Word table cells to Excel cells
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
Cells(resultRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
Next iCol
resultRow = resultRow + 1
Next iRow
End With
resultRow = resultRow + 1
Next tableStart
End With
End Sub
您可以只从Word复制整个表,然后使用Worksheet
的PasteSpecial
方法将其粘贴到Excel中。 该PasteSpecial
的方法Worksheet
有不同的选项来PasteSpecial
一个方法Range
。 这些选项之一是“ Format
,并且HTML
设置将Word表的格式应用于要粘贴到的Excel范围。
Worksheet
的PasteSpecial
方法仅使用活动单元格,因此您必须首先Select
目标Range
。 看起来有点丑陋,但我看不到其他选择。
这是一个例子:
Option Explicit
Sub Test()
Dim rngTarget As Range
Set rngTarget = ThisWorkbook.Worksheets("Sheet1").Range("A1")
WordTableToExcel "C:\Users\Robin\Desktop\foo1.docx", 1, rngTarget
End Sub
Sub WordTableToExcel(strWordFile As String, intWordTableIndex As Integer, rngTarget As Range)
Dim objWordApp As Object
Dim objWordTable As Object
On Error GoTo CleanUp
'get table from word document
Set objWordApp = GetObject(strWordFile)
Set objWordTable = objWordApp.Tables(intWordTableIndex)
objWordTable.Range.Copy
'paste table to sheet
rngTarget.Select
rngTarget.Parent.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
CleanUp:
'clean up word references
Set objWordTable = Nothing
Set objWordApp = Nothing
End Sub
关于有关如何应用于多个文件的问题-您可以继续为每个word文档调用此可重用Sub
,并根据现有代码中的循环遍历该文档中的表。
复制具有相同目录中多个文档格式的表。
Sub ImportWordTable()
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 = True
Range("A:AZ").ClearContents
Set Target = 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"
ElseIf tableNo > 1 Then
tableNo = InputBox(WordDoc.Name & " contains " & tableNo & " tables." & vbCrLf & _
"Enter the table to start from", "Import Word Table", "1")
End If
For tableStart = 1 To tableTot
With .tables(tableStart)
.Range.Copy
'Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
Target.Activate
ActiveSheet.Paste
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.