ExcelVBA一键导入Word简历信息到 EXCEL中

VBA一键导入Word简历信息到 EXCEL中

【问题】：公司有几个这样Word文档的简历文件，要把他们的信息收集起来到Excel文件中，

【常规做法】打开word~复制~粘贴到Excel中，还要再整理，10多个还可以，如果几百个文件，那就~~~~天啊

【目标】：一键完成

【代码】

Sub DoMyWork()

Dim tmpSHT As Worksheet

Dim NowW As Long, tmp As String, FN As String, In_Count As Long

' Dim myApp As New Word.Application

Dim myDOC, myApp, tmpHead, brr

If MsgBox("该程序运行的前提是需要导入的文档和当前工作簿在同一个目录中，且没有其他无关的文档。" & vbNewLine & _

"当前环境是否满足上述前提？", vbQuestion + vbYesNo, "Eersoft-提示") = vbNo Then Exit Sub

Set myApp = CreateObject("Word.Application")

myApp.Visible = False

myApp.DisplayAlerts = wdAlertsNone

Set tmpSHT = ThisWorkbook.Sheets(1)

tmpHead = Array("姓名", "性别", "出生日期", _

"民族", "籍贯", "出生地", _

"入党时间", "参加工作时间", _

"健康状况", "专业技术职称", "熟悉专业有何专长", _

"全日制教育", "毕业院校系及专业", "在职教育", _

"毕业院校系及专业", "联系电话", "身份证号码", _

"现任职务", "现单位性质", "任现职时间", "任现级别时间")

tmpSHT.Range("a1:u1") = tmpHead

FN = Dir(ThisWorkbook.Path & "\*.doc")

Do Until FN = ""

FN = ThisWorkbook.Path & "\" & FN

Set myDOC = myApp.Documents.Open(FN)

In_Count = In_Count + 1

With myDOC.Tables(1)

tmp = .Cell(1, 2).Range.Text & "," & _

.Cell(1, 4).Range.Text &"," & _

.Cell(1, 6).Range.Text &"," & _

.Cell(2, 2).Range.Text &"," & _

.Cell(2, 4).Range.Text &"," & _

.Cell(2, 6).Range.Text &"," & _

.Cell(3, 2).Range.Text &"," & _

.Cell(3, 4).Range.Text &"," & _

.Cell(3, 6).Range.Text &"," & _

.Cell(4, 2).Range.Text &"," & _

.Cell(4, 4).Range.Text &"," & _

.Cell(5, 3).Range.Text &"," & _

.Cell(5, 5).Range.Text &"," & _

.Cell(6, 3).Range.Text &"," & _

.Cell(6, 5).Range.Text &"," & _

.Cell(7, 2).Range.Text &"," & _

.Cell(7, 4).Range.Text &"," & _

.Cell(8, 2).Range.Text &"," & _

.Cell(8, 4).Range.Text &"," & _

.Cell(9, 2).Range.Text &"," & _

.Cell(9, 4).Range.Text

End With

tmp = Replace(tmp, Chr(13), "")

tmp = Replace(tmp, Chr(7), "")

tmp = Replace(tmp, Chr(32), "")

brr = Split(tmp, ",")

NowW = tmpSHT.[a65536].End(xlUp).Row + 1

tmpSHT.Range("a" & CStr(NowW) & ":u" &CStr(NowW)) = brr

myDOC.Close False

FN = Dir()

Loop

myApp.Quit

Set tmpSHT = Nothing

Set myDOC = Nothing

Set myApp = Nothing

MsgBox "导入完毕，共导入" & CStr(In_Count)& "个文档，请检查。", vbInformation + vbOKOnly,"Eersoft-完成"

End Sub

【运行~成功】