如何將1000多字的信息提取到Excel中？

WORD文件是壹個報表，裏面包含了每個人的信息。如何將多個文件中的姓名，電話，身份證號，家庭住址提取到EXCL中進行統計分析？因為文件太多，希望大家幫忙給個高效的辦法！提前感謝！

大致結構如下:

子摘要()

range(" a 1 ")current region . offset(1，0)。清除內容

細胞。Borders.LineStyle = xlNone

申請。ScreenUpdating = False

將Word作為Word變暗。文件

將wordapp作為對象變暗

Dim cPath$，cFile$，i%，arr()

cPath = ThisWorkbook。路徑與路徑。"\"

cFile = Dir(cPath & amp；"*.多克？”)

設置wordapp = CreateObject("word。應用”)

Do While cFile & lt& gt""

設置wordD = wordapp。文檔。打開(cPath & ampcFile)

i = i + 1

ReDim Preserve arr(1到4，1到I)

用wordD.tables(4)

arr(1，i) = Trim(Replace(替換(。Cell(2，1).Range.Text，Chr(7)，"")，Chr(13)，""))

arr(3，i) = Trim(Replace(替換(。Cell(2，3).Range.Text，Chr(7)，"")，Chr(13)，""))

以…結尾

帶wordD

arr(2，i) = Trim(Replace(替換(。表格(3)。Cell(2，4).Range.Text，Chr(7)，"")，Chr(13)，""))

arr(4，i) = Trim(Replace(替換(。表格(5)。Cell(2，2).Range.Text，Chr(7)，"")，Chr(13)，""))

以…結尾

wordD。關閉

cFile = Dir

環

設置wordD = Nothing

wordapp。放棄

範圍(“a2”)。調整大小(I，4)。價值=應用。轉置

範圍(" a 1 :D " & amp；I+1). borders . line style = XL continuous

申請。ScreenUpdating = True

末端接頭

大神，如果中間有幾個不同格式的文檔，錯誤會停止，數據不會保存。不能提取的可以自動跳過嗎？

向程序中添加代碼

出錯時繼續下壹步

子提取信息()

range(" a 1 ")current region . offset(1，0)。清除內容

細胞。Borders.LineStyle = xlNone

申請。ScreenUpdating = False

將Word作為Word變暗。文件

將wordapp作為對象變暗

Dim cPath$，cFile$，i%，arr()

cPath = ThisWorkbook。路徑與路徑。"\"

cFile = Dir(cPath & amp；"*.多克？”)

設置wordapp = CreateObject("word。應用”)

Do While cFile & lt& gt""

設置wordD = wordapp。文檔。打開(cPath & ampcFile)

i = i + 1

ReDim Preserve arr(1到4，1到I)

帶wordD

arr(1，i) = Replace(替換(。paragraphs(18). range . text，Chr(7)，"")，Chr(13)，"")

arr(3，i) = Replace(Replace(。段落(20).Range.Text，Chr(7)，"")，Chr(13)，"")

arr(2，i) = Replace(Replace(。Paragraphs(44).Range.Text，Chr(7)，"")，Chr(13)，"")

arr(4，i) = Replace(Replace(。Paragraphs(82).Range.Text，Chr(7)，"")，Chr(13)，"")

以…結尾

wordD。關閉

cFile = Dir

環

設置wordD = Nothing

wordapp。放棄

範圍(“a2”)。調整大小(I，4)。價值=應用。轉置

範圍(" a 1 :D " & amp；I+1). borders . line style = XL continuous

申請。ScreenUpdating = True

末端接頭

提示找不到項目庫，

請看圖，報出以下選項。