我的2016年vba学习总结

lsc900707 · 发表于 2017-1-6 20:58

我的另一个帖子，是关于word转excel的，之前看过多个单独的几份简历汇总到excel的，但没有看过一个word中多份简历汇总的，所以求助.
如何提取word文档中多个简历信息至excel汇总表
http://club.excelhome.net/thread-1291824-1-1.html
(出处: ExcelHome技术论坛)
感谢hhjjpp大侠及时施以援手，使得问题得以解决：

Private Sub CommandButton1_Click()
Dim wd, i&
Set wd = CreateObject("word.application")
wd.Documents.Open ThisWorkbook.Path & "\简历信息表.doc"
With wd.activedocument
For i = 1 To .Tables.Count
   Cells(i + 1, "b") = Replace(.Tables(i).Cell(2, 2), Chr(7), "")
   Cells(i + 1, "c") = Replace(.Tables(i).Cell(2, 4), Chr(7), "")
   Cells(i + 1, "d") = Replace(.Tables(i).Cell(2, 6), Chr(7), "")
   Cells(i + 1, "e") = Replace(.Tables(i).Cell(3, 2), Chr(7), "")
   Cells(i + 1, "f") = Replace(.Tables(i).Cell(3, 4), Chr(7), "")
   Cells(i + 1, "g") = Replace(.Tables(i).Cell(3, 6), Chr(7), "")
   Cells(i + 1, "h") = Replace(.Tables(i).Cell(4, 2), Chr(7), "")
   Cells(i + 1, "i") = Replace(.Tables(i).Cell(4, 4), Chr(7), "")
   Cells(i + 1, "j") = Replace(.Tables(i).Cell(5, 2), Chr(7), "")
   Cells(i + 1, "k") = Replace(.Tables(i).Cell(5, 4), Chr(7), "")
   Cells(i + 1, "l") = Replace(.Tables(i).Cell(6, 3), Chr(7), "")
   Cells(i + 1, "m") = Replace(.Tables(i).Cell(6, 5), Chr(7), "")
   Cells(i + 1, "n") = Replace(.Tables(i).Cell(7, 3), Chr(7), "")
   Cells(i + 1, "o") = Replace(.Tables(i).Cell(7, 5), Chr(7), "")
   Cells(i + 1, "p") = Replace(.Tables(i).Cell(8, 2), Chr(7), "")
   Cells(i + 1, "q") = Replace(.Tables(i).Cell(8, 4), Chr(7), "")
   Cells(i + 1, "r") = Replace(.Tables(i).Cell(9, 2), Chr(7), "")
   Cells(i + 1, "s") = Replace(.Tables(i).Cell(9, 4), Chr(7), "")
   Cells(i + 1, "t") = Replace(.Tables(i).Cell(9, 6), Chr(7), "")
   Cells(i + 1, "u") = Replace(.Tables(i).Cell(10, 2), Chr(7), "")
   Cells(i + 1, "v") = Replace(.Tables(i).Cell(13, 2), Chr(7), "")
   Cells(i + 1, "w") = Replace(.Tables(i).Cell(13, 3), Chr(7), "")
   Cells(i + 1, "x") = Replace(.Tables(i).Cell(14, 2), Chr(7), "")
   Cells(i + 1, "y") = Replace(.Tables(i).Cell(14, 3), Chr(7), "")
   Cells(i + 1, "z") = Replace(.Tables(i).Cell(14, 4), Chr(7), "")
   Cells(i + 1, "aa") = Replace(.Tables(i).Cell(15, 2), Chr(7), "")
   Cells(i + 1, "ab") = Replace(.Tables(i).Cell(15, 3), Chr(7), "")
   Cells(i + 1, "ac") = Replace(.Tables(i).Cell(15, 4), Chr(7), "")
   Cells(i + 1, "ad") = Replace(.Tables(i).Cell(16, 2), Chr(7), "")
   Cells(i + 1, "ae") = Replace(.Tables(i).Cell(16, 3), Chr(7), "")
   Cells(i + 1, "af") = Replace(.Tables(i).Cell(16, 4), Chr(7), "")
   Cells(i + 1, "ag") = Replace(.Tables(i).Cell(19, 1), Chr(7), " ") & Replace(.Tables(i).Cell(19, 2), Chr(7), " ") & Replace(.Tables(i).Cell(19, 3), Chr(7), " ") & Replace(.Tables(i).Cell(19, 4), Chr(7), Chr(13)) & Replace(.Tables(i).Cell(20, 1), Chr(7), " ") & Replace(.Tables(i).Cell(20, 2), Chr(7), " ") & Replace(.Tables(i).Cell(20, 3), Chr(7), " ") & Replace(.Tables(i).Cell(20, 4), Chr(7), "")
   Cells(i + 1, "ah") = Replace(.Tables(i).Cell(23, 1), Chr(7), " ") & Replace(.Tables(i).Cell(23, 2), Chr(7), " ") & Replace(.Tables(i).Cell(23, 3), Chr(7), " ") & Replace(.Tables(i).Cell(23, 4), Chr(7), Chr(13)) & Replace(.Tables(i).Cell(24, 1), Chr(7), " ") & Replace(.Tables(i).Cell(24, 2), Chr(7), " ") & Replace(.Tables(i).Cell(24, 3), Chr(7), " ") & Replace(.Tables(i).Cell(24, 4), Chr(7), "")
   Cells(i + 1, "ai") = Replace(.Tables(i).Cell(29, 1), Chr(7), "")
Next
.Close False
wd.Quit
End With

End Sub

lsc900707 · 发表于 2017-1-6 21:03

以下代码感谢http://club.excelhome.net/home.php?mod=space&uid=3195546大侠提供思路和框架：

Sub word文档转excel汇总()
   On Error Resume Next
   [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
   Set Wordapp = CreateObject("Word.Application")
   cPath = ThisWorkbook.Path & "\"
   cFile = Dir(cPath & "*.doc?")
   Do While cFile <> ""
      Set wordD = Wordapp.Documents.Open(cPath & cFile)
      For i = 1 To wordD.Tables.Count
         With wordD.Tables(i)
               arr(i, 1) = 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), "")
               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
      Next
      wordD.Close
      cFile = Dir
   Loop
   Set wordD = Nothing
   Wordapp.Quit
   Sheet1.Range("A2").Resize(i, 35) = arr
   Application.ScreenUpdating = True
End Sub

l沙漠中的绿洲f · 发表于 2017-1-15 20:41

太棒了。你学习的动力是什么呀？

lsc900707 · 发表于 2017-1-15 21:02

l沙漠中的绿洲f 发表于 2017-1-15 20:41
太棒了。你学习的动力是什么呀？

一是兴趣，二是怕无所事事，浑浑噩噩过日子。

l沙漠中的绿洲f · 发表于 2017-1-15 21:06

lsc900707 发表于 2017-1-15 21:02
一是兴趣，二是怕无所事事，浑浑噩噩过日子。

是我学习的榜样！赞一个

lsc900707 · 发表于 2017-1-15 21:08

l沙漠中的绿洲f 发表于 2017-1-15 21:06
是我学习的榜样！赞一个

用点心，大家都可以的，你们的条件应该比我更优越。

鹤舞西楼 · 发表于 2017-1-28 07:27

我也想学习，没有毅力啊

lsc900707 · 发表于 2017-1-28 07:51

鹤舞西楼发表于 2017-1-28 07:27
我也想学习，没有毅力啊

给自己一点压力，有压力就有动力。加油！

l沙漠中的绿洲f · 发表于 2017-1-31 21:03

这一年付出的辛苦不少呀。你是干什么工作的？

l沙漠中的绿洲f · 发表于 2017-1-31 21:14

lsc900707 发表于 2017-1-1 14:56
这两个帖子很快得到大师们的答复，我很感动。觉得EH就像个家，很温馨。大师们乐于助人的精神令我钦佩。在这 ...

你也从昨天的小白，变成了今天的大师

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

[交流] 我的2016年vba学习总结