利用ExcelVBA提取word中的数据

lkqsmxw

http://club.excelhome.net/forum. ... p;extra=#pid9799860
常用工具7.5版.rar

mhps159357

         处理数据联系QQ595213060
点击表格1  指定代码  代码框菜单栏点击   工具——引用    找到Microsoft Word 12.0 Object

library(不同OFFICE版本可能是11.0  或者14.0等）  再将下面代码复制进去运行F5即可
Sub ss()
i = 1
Dim swk As Word.Application
Dim sck As document
Dim st$
st = Dir(ThisWorkbook.Path & "\*.doc?")
Do While st <> ""
i = i + 1
Set swk = New Word.Application
Set sck = swk.documents.Open(ThisWorkbook.Path & "\" & st, , True)
Sheets("sheet1").Cells(i, "f") = Left(sck.tables(1).Range.Cells(3).Range, Len(sck.tables

(1).Range.Cells(3).Range) - 1)
Sheets("sheet1").Cells(i, "h") = Left(sck.tables(1).Range.Cells(12).Range, Len(sck.tables

(1).Range.Cells(12).Range) - 1)
Sheets("sheet1").Cells(i, "i") = Left(sck.tables(1).Range.Cells(5).Range, Len(sck.tables

(1).Range.Cells(5).Range) - 1)
Sheets("sheet1").Cells(i, "j") = Left(sck.tables(1).Range.Cells(7).Range, Len(sck.tables

(1).Range.Cells(7).Range) - 1)
Sheets("sheet1").Cells(i, "k") = Left(sck.tables(1).Range.Cells(30).Range, Len(sck.tables

(1).Range.Cells(30).Range) - 1)
Sheets("sheet1").Cells(i, "l") = Left(sck.tables(1).Range.Cells(36).Range, Len(sck.tables

(1).Range.Cells(36).Range) - 1)
Sheets("sheet1").Cells(i, "m") = Left(sck.tables(1).Range.Cells(34).Range, Len(sck.tables

(1).Range.Cells(34).Range) - 1)
Sheets("sheet1").Cells(i, "n") = Left(sck.tables(1).Range.Cells(16).Range, Len(sck.tables

(1).Range.Cells(16).Range) - 1)
Sheets("sheet1").Cells(i, "o") = Left(sck.tables(1).Range.Cells(19).Range, Len(sck.tables

(1).Range.Cells(19).Range) - 1)
Sheets("sheet1").Cells(i, "p") = Left(sck.tables(1).Range.Cells(21).Range, Len(sck.tables

(1).Range.Cells(21).Range) - 1)
Sheets("sheet1").Cells(i, "r") = Left(sck.tables(1).Range.Cells(14).Range, Len(sck.tables

(1).Range.Cells(14).Range) - 1)
swk.documents(1).Close
swk.Quit
Set swk = Nothing
Set sck = Nothing
st = Dir
Loop
End Sub

mhps159357

处理数据联系QQ595213060
点击表格1  指定代码  代码框菜单栏点击   工具——引用    找到Microsoft Word 12.0 Object

library  将前面小方框钩上，确定(不同OFFICE版本可能是11.0  或者14.0等）  再将下面代码复制进去运行F5即可
Sub ss()
i = 1
Dim swk As Word.Application
Dim sck As document
Dim st$
st = Dir(ThisWorkbook.Path & "\*.doc?")
Do While st <> ""
i = i + 1
Set swk = New Word.Application
Set sck = swk.documents.Open(ThisWorkbook.Path & "\" & st, , True)
Sheets("sheet1").Cells(i, "f") = Left(sck.tables(1).Range.Cells(3).Range, Len(sck.tables

(1).Range.Cells(3).Range) - 1)
Sheets("sheet1").Cells(i, "h") = Left(sck.tables(1).Range.Cells(12).Range, Len(sck.tables

(1).Range.Cells(12).Range) - 1)
Sheets("sheet1").Cells(i, "i") = Left(sck.tables(1).Range.Cells(5).Range, Len(sck.tables

(1).Range.Cells(5).Range) - 1)
Sheets("sheet1").Cells(i, "j") = Left(sck.tables(1).Range.Cells(7).Range, Len(sck.tables

(1).Range.Cells(7).Range) - 1)
Sheets("sheet1").Cells(i, "k") = Left(sck.tables(1).Range.Cells(30).Range, Len(sck.tables

(1).Range.Cells(30).Range) - 1)
Sheets("sheet1").Cells(i, "l") = Left(sck.tables(1).Range.Cells(36).Range, Len(sck.tables

(1).Range.Cells(36).Range) - 1)
Sheets("sheet1").Cells(i, "m") = Left(sck.tables(1).Range.Cells(34).Range, Len(sck.tables

(1).Range.Cells(34).Range) - 1)
Sheets("sheet1").Cells(i, "n") = Left(sck.tables(1).Range.Cells(16).Range, Len(sck.tables

(1).Range.Cells(16).Range) - 1)
Sheets("sheet1").Cells(i, "o") = Left(sck.tables(1).Range.Cells(19).Range, Len(sck.tables

(1).Range.Cells(19).Range) - 1)
Sheets("sheet1").Cells(i, "p") = Left(sck.tables(1).Range.Cells(21).Range, Len(sck.tables

(1).Range.Cells(21).Range) - 1)
Sheets("sheet1").Cells(i, "r") = Left(sck.tables(1).Range.Cells(14).Range, Len(sck.tables

(1).Range.Cells(14).Range) - 1)
swk.documents(1).Close
swk.Quit
Set swk = Nothing
Set sck = Nothing
st = Dir
Loop
End Sub

抓不住的风

大佬，我用esDoc2Xls，导入模板显示类型不匹配，错误13，怎么搞？求教求教求教

wengjl

EXCEL VBA 统计WORD文档中第一个表格内的格子数的语句如何写？

h2016

word提取到excel