提取Word表格到Excel中，涉及Word VBA和Excel VBA知识。
可以用插件一键搞定
Sub 提取模板()
Set d = CreateObject("scripting.dictionary")
i = 0
j = 0
k = 0
Dim doc As Document
Set doc = Documents.Open("C:\Users\28553\Desktop\模板.docx")
If doc.Tables.Count = 0 Then
doc.Close False
MsgBox ("文档中没有找到表格！")
Exit Sub
End If
Dim tbl As Table
Dim c As Cell
For Each tbl In doc.Tables
i = i + 1
For Each c In tbl.Range.Cells
j = j + 1
s = l(c.Range.Text)
If Len(s) > 0 Then
d(i & "|" & j & "|" & s) = ""
End If
Next
j = 0
Next
kr = d.keys
ir = d.items
doc.Close False
'/新建导出表格
Set exl = CreateObject("excel.application")
exl.Visible = True
Set wb = exl.workbooks.Add
Set sht = wb.activesheet
For i = 0 To UBound(kr)
arr = Split(kr(i), "|")
sht.Cells(1, i + 3).Value = arr(2)
Next
sht.Cells(1, 1).Value = "序号"
sht.Cells(1, 2).Value = "文档名"
'/开始提取数据
ReDim jg(0 To 10000, 0 To UBound(kr) + 2)
f = Dir("C:\Users\28553\Desktop\新建文件夹\*.doc*")
Do While f <> ""
Set doc = Documents.Open("C:\Users\28553\Desktop\新建文件夹\" & f)
For i = 0 To UBound(kr)
arr = Split(kr(i), "|")
jg(k, 0) = k + 1
jg(k, 1) = f
jg(k, i + 2) = l(doc.Tables(Val(arr(0))).Range.Cells(Val(arr(1))).Range.Text)
Next
k = k + 1
doc.Close False
f = Dir
Loop
'/写入excel和处理格式
sht.Range("a2").Resize(k, UBound(jg, 2) + 1) = jg
'调整格式
'作用：调整格式
'常见的居中，自动适应列宽，边框加粗
With sht.usedrange
.HorizontalAlignment = xlCenter '水平居中
.VerticalAlignment = xlCenter '竖直居中
.Borders(8).LineStyle = xlContinuous
.Borders(9).LineStyle = xlContinuous
.Borders(7).LineStyle = xlContinuous
.Borders(10).LineStyle = xlContinuous
.Borders(11).LineStyle = xlContinuous
.Borders(12).LineStyle = xlContinuous
End With
sht.Columns.AutoFit
MsgBox "完成！"
End Sub
Function l(n)
l = Replace(Replace(n, Chr(7), ""), Chr(13), "")
End Function
标签：Word,魔方,doc,Excel,xlContinuous,sht,Borders,jg From： https://www.cnblogs.com/vbashuo/p/17007726.html