如何提取word文档中多个简历信息至excel汇总表

lsc900707 · 发表于 2016-7-27 06:15

本帖最后由 lsc900707 于 2016-7-27 08:08 编辑

如何使用VBA提取附件word文档中多个简历信息至excel汇总表，如姓名、性别、身份证号码、工作经历、家庭成员信息等，其中工作经历及家庭成员信息批量汇总至相应单元格中（详见附件），请各位老师帮忙~谢谢~

182197315 · 发表于 2016-7-27 09:10

本帖最后由 182197315 于 2016-7-27 09:25 编辑

Sub 汇总()
[A2:AI250].ClearContents
Application.ScreenUpdating = False
Dim cPath$, cFile$, str$, i%, arr(1 To 500, 1 To 16)
Dim wordD As Word.Document
Dim wordapp As Object
cPath = ThisWorkbook.Path & "\"
cFile = Dir(cPath & "*.doc?")
Set wordapp = CreateObject("Word.Application")
Do While cFile <> ""
      Set wordD = wordapp.Documents.Open(cPath & cFile)
      i = i + 1
      With wordD.Tables(1)
         arr(i, 2) = Replace(.Cell(2, 2).Range.Text, Chr(7), "")
         arr(i, 3) = Replace(.Cell(2, 4).Range.Text, Chr(7), "")
         arr(i, 4) = Replace(.Cell(2, 6).Range.Text, Chr(7), "")
         arr(i, 5) = Replace(.Cell(3, 2).Range.Text, Chr(7), "")
         arr(i, 6) = Replace(.Cell(3, 4).Range.Text, Chr(7), "")
         arr(i, 7) = Replace(.Cell(3, 6).Range.Text, Chr(7), "")
         arr(i, 8) = Replace(.Cell(4, 2).Range.Text, Chr(7), "")
         arr(i, 9) = Replace(.Cell(4, 4).Range.Text, Chr(7), "")
         arr(i, 10) = Replace(.Cell(5, 2).Range.Text, Chr(7), "")
         arr(i, 11) = Replace(.Cell(5, 4).Range.Text, Chr(7), "")
         arr(i, 12) = Replace(.Cell(6, 3).Range.Text, Chr(7), "")
         arr(i, 13) = Replace(.Cell(6, 5).Range.Text, Chr(7), "")
         arr(i, 14) = Replace(.Cell(7, 3).Range.Text, Chr(7), "")
         arr(i, 15) = Replace(.Cell(7, 5).Range.Text, Chr(7), "")
      End With
      wordD.Close
      cFile = Dir
Loop
Set wordD = Nothing
wordapp.Quit
Me.Range("A2").Resize(i, 35) = arr
Application.ScreenUpdating = true
End Sub

楼主接着写吧，眼睛都看花了

lsc900707 · 发表于 2016-7-27 09:16

182197315 发表于 2016-7-27 09:10
Sub 汇总()
[A2:AI250].ClearContents
Application.ScreenUpdating = False

先行谢过。我试试看。

lsc900707 · 发表于 2016-7-27 10:42

本帖最后由 lsc900707 于 2016-7-27 10:44 编辑

182197315 发表于 2016-7-27 09:10
Sub 汇总()
[A2:AI250].ClearContents
Application.ScreenUpdating = False

Sub 汇总()
[A2:AI250].ClearContents
   Application.ScreenUpdating = False
   Dim cPath$, cFile$, str$, i%, arr(1 To 500, 1 To 35)
   Dim wordD As Word.Document
   Dim wordapp As Object
   cPath = ThisWorkbook.Path & "\"
   cFile = Dir(cPath & "*.doc?")
   Set wordapp = CreateObject("Word.Application")
   Do While cFile <> ""
      Set wordD = wordapp.Documents.Open(cPath & cFile)
      i = i + 1
      With wordD.Tables(1)
         arr(i, 2) = Replace(.Cell(2, 2).Range.Text, Chr(7), "")
         arr(i, 3) = Replace(.Cell(2, 4).Range.Text, Chr(7), "")
         arr(i, 4) = Replace(.Cell(2, 6).Range.Text, Chr(7), "")
         arr(i, 5) = Replace(.Cell(3, 2).Range.Text, Chr(7), "")
         arr(i, 6) = Replace(.Cell(3, 4).Range.Text, Chr(7), "")
         arr(i, 7) = Replace(.Cell(3, 6).Range.Text, Chr(7), "")
         arr(i, 8) = Replace(.Cell(4, 2).Range.Text, Chr(7), "")
         arr(i, 9) = Replace(.Cell(4, 4).Range.Text, Chr(7), "")
         arr(i, 10) = Replace(.Cell(5, 2).Range.Text, Chr(7), "")
         arr(i, 11) = Replace(.Cell(5, 4).Range.Text, Chr(7), "")
         arr(i, 12) = Replace(.Cell(6, 3).Range.Text, Chr(7), "")
         arr(i, 13) = Replace(.Cell(6, 5).Range.Text, Chr(7), "")
         arr(i, 14) = Replace(.Cell(7, 3).Range.Text, Chr(7), "")
         arr(i, 15) = Replace(.Cell(7, 5).Range.Text, Chr(7), "")
         arr(i, 16) = Replace(.Cell(8, 2).Range.Text, Chr(7), "")
         arr(i, 17) = Replace(.Cell(8, 4).Range.Text, Chr(7), "")
         arr(i, 18) = Replace(.Cell(9, 2).Range.Text, Chr(7), "")
         arr(i, 19) = Replace(.Cell(9, 4).Range.Text, Chr(7), "")
         arr(i, 20) = Replace(.Cell(9, 6).Range.Text, Chr(7), "")
         arr(i, 21) = Replace(.Cell(10, 2).Range.Text, Chr(7), "")
         arr(i, 22) = Replace(.Cell(13, 2).Range.Text, Chr(7), "")
         arr(i, 23) = Replace(.Cell(13, 3).Range.Text, Chr(7), "")
         arr(i, 24) = Replace(.Cell(14, 2).Range.Text, Chr(7), "")
         arr(i, 25) = Replace(.Cell(14, 3).Range.Text, Chr(7), "")
         arr(i, 26) = Replace(.Cell(14, 4).Range.Text, Chr(7), "")
         arr(i, 27) = Replace(.Cell(15, 2).Range.Text, Chr(7), "")
         arr(i, 28) = Replace(.Cell(15, 3).Range.Text, Chr(7), "")
         arr(i, 29) = Replace(.Cell(15, 4).Range.Text, Chr(7), "")
         arr(i, 30) = Replace(.Cell(16, 2).Range.Text, Chr(7), "")
         arr(i, 31) = Replace(.Cell(16, 3).Range.Text, Chr(7), "")
         arr(i, 32) = Replace(.Cell(16, 4).Range.Text, Chr(7), "")
         arr(i, 33) = Replace(.Cell(19, 1).Range.Text, Chr(7), "") & Replace(.Cell(19, 2).Range.Text, Chr(7), "") _
            & Replace(.Cell(19, 3).Range.Text, Chr(7), "") & Replace(.Cell(19, 4).Range.Text, Chr(7), "") & Chr(13) _
         & Replace(.Cell(20, 1).Range.Text, Chr(7), "") & Replace(.Cell(20, 2).Range.Text, Chr(7), "") _
            & Replace(.Cell(20, 3).Range.Text, Chr(7), "") & Replace(.Cell(20, 4).Range.Text, Chr(7), "")
         arr(i, 34) = Replace(.Cell(23, 1).Range.Text, Chr(7), "") & Replace(.Cell(23, 2).Range.Text, Chr(7), "") _
            & Replace(.Cell(23, 3).Range.Text, Chr(7), "") & Replace(.Cell(23, 4).Range.Text, Chr(7), "") _
         & Replace(.Cell(23, 5).Range.Text, Chr(7), "") & Replace(.Cell(23, 6).Range.Text, Chr(7), "") & Chr(13) _
         & Replace(.Cell(24, 1).Range.Text, Chr(7), "") & Replace(.Cell(24, 2).Range.Text, Chr(7), "") _
            & Replace(.Cell(24, 3).Range.Text, Chr(7), "") & Replace(.Cell(24, 4).Range.Text, Chr(7), "") _
         & Replace(.Cell(24, 5).Range.Text, Chr(7), "") & Replace(.Cell(24, 6).Range.Text, Chr(7), "")
         arr(i, 35) = Replace(.Cell(29, 1).Range.Text, Chr(7), "")

      End With
      wordD.Close
      cFile = Dir
   Loop
   Set wordD = Nothing
   wordapp.Quit
   Sheet1.Range("A2").Resize(i, 35) = arr
   Application.ScreenUpdating = True
End Sub
亲，终于依样画葫芦画出来了，但是为什么只有第一个的信息？还有33和34列可以简化代码吗？

182197315 · 发表于 2016-7-27 12:47

本帖最后由 182197315 于 2016-7-27 15:35 编辑

Sub 汇总()
[A2:AI250].ClearContents
Application.ScreenUpdating = False
Dim myFile$, i%, arr(1 To 500, 1 To 35)
Dim wordD As Word.Document
Dim Wordapp As Object
Set Wordapp = CreateObject("Word.Application")
myFile = ThisWorkbook.Path & "\" & "简历信息表.docx"
Set wordD = Wordapp.Documents.Open(myFile)
      For i = 1 To wordD.Tables.Count
         With wordD.Tables(i)
            arr(i, 2) = Replace(.Cell(2, 2).Range.Text, Chr(7), "")
            arr(i, 3) = Replace(.Cell(2, 4).Range.Text, Chr(7), "")
            arr(i, 4) = Replace(.Cell(2, 6).Range.Text, Chr(7), "")
            arr(i, 5) = Replace(.Cell(3, 2).Range.Text, Chr(7), "")
            arr(i, 6) = Replace(.Cell(3, 4).Range.Text, Chr(7), "")
            arr(i, 7) = Replace(.Cell(3, 6).Range.Text, Chr(7), "")
            arr(i, 8) = Replace(.Cell(4, 2).Range.Text, Chr(7), "")
            arr(i, 9) = Replace(.Cell(4, 4).Range.Text, Chr(7), "")
            arr(i, 10) = Replace(.Cell(5, 2).Range.Text, Chr(7), "")
            arr(i, 11) = Replace(.Cell(5, 4).Range.Text, Chr(7), "")
            arr(i, 12) = Replace(.Cell(6, 3).Range.Text, Chr(7), "")
            arr(i, 13) = Replace(.Cell(6, 5).Range.Text, Chr(7), "")
            arr(i, 14) = Replace(.Cell(7, 3).Range.Text, Chr(7), "")
            arr(i, 15) = Replace(.Cell(7, 5).Range.Text, Chr(7), "")
         End With
      Next
wordD.Close
Set wordD = Nothing
Wordapp.Quit
Me.Range("A2").Resize(i, 35) = arr
Application.ScreenUpdating = True
End Sub



干嘛把这多简历放在一个word文档里，分开放多好

lsc900707 · 发表于 2016-7-27 12:55

182197315 发表于 2016-7-27 12:47
Sub 汇总()
[A2:AI250].ClearContents
Application.ScreenUpdating = False

呃，我懂了，要一个简历一个簿。我只是刚学这个题，想练练。

jiminyanyan · 发表于 2016-7-27 12:59

lsc900707 发表于 2016-7-27 12:55
呃，我懂了，要一个简历一个簿。我只是刚学这个题，想练练。

家庭成员有多有少，表格格式会变掉的。

lsc900707 · 发表于 2016-7-27 13:30

本帖最后由 lsc900707 于 2016-7-27 13:31 编辑

jiminyanyan 发表于 2016-7-27 12:59
家庭成员有多有少，表格格式会变掉的。

谢谢，我正在处理这个问题，表格不规范的话，就出问题了。
害得我必须加上防错语句。
大神，33列和34列有没有更简洁的代码？

182197315 · 发表于 2016-7-27 13:38

lsc900707 发表于 2016-7-27 12:55
呃，我懂了，要一个简历一个簿。我只是刚学这个题，想练练。

一个文档装一个简历，符合习惯，汇总起来也省事

lsc900707 · 发表于 2016-7-27 13:47

182197315 发表于 2016-7-27 13:38
一个文档装一个简历，符合习惯，汇总起来也省事

谢谢！看来我刚学习这个课题就挑了个“刺”！

		自动登录	找回密码
密码			免费注册

[求助] 如何提取word文档中多个简历信息至excel汇总表

评分

评分