请教提取word数据到excel的vba改进方法
发布网友
发布时间：2022-04-21 19:19
共5个回答
热心网友
时间：2023-05-20 07:39
给出一段代码供参考。
Public myPath As String
Public wjmZD
Public zL As String
Sub 提取简历()
Dim Js As Integer, MyName As String
Dim Gs As Long
zL = Cells(3, 4).Text
'选择文件夹
ChDrive ThisWorkbook.Path
Call SelectFolder(myPath)
Dim fs, f, f1, fc, s
'文件名字典初始化
Set wjmZD = CreateObject("scripting.dictionary")
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(myPath) '在括号内输入你指定的目录
Set fc = f.Files
Gs = 0
For Each f1 In fc
MyName = f1.Name
If InStr(MyName, "doc") > 0 And Left(MyName, 1) <> "~" Then
Gs = Gs + 1
wjmZD.Add MyName, Gs
End If
Next f1
Call tqjl(zL)
End Sub
Sub SelectFolder(ByRef myPath)
'选择单一文件夹
'www.okexcel.com.cn
'Set fd = Application.FileDialog(msoFileDialogOpen)
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.InitialFileName = ThisWorkbook.Path
'With Application.FileDialog(msoFileDialogFolderPicker)
With fd
If .Show = -1 Then
'FileDialog 对象的 Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）。
'MsgBox "您选择的文件夹是：" & .SelectedItems(1), vbOKOnly + vbInformation, "智能Excel"
myPath = .SelectedItems(1)
End If
End With
End Sub
Sub tqjl(zL)
'On Error GoTo jiesu
Dim jgarr, jgJs As Long
Dim lsArr(1 To 100) As String, lsJs As Integer
Dim Wdoc
Dim MyDocument
jgJs = wjmZD.Count
arr = wjmZD.keys
ReDim jgarr(1 To jgJs, 1 To 32) '
Set Wdoc = CreateObject("word.application")
Wdoc.Visible = False
With Wdoc
For i = 1 To jgJs
MyName = arr(i - 1)
导出路径文件名 = myPath & "\" & MyName
Set MyDocument = .Documents.Open(导出路径文件名)
.Visible = True
Select Case zL
Case "2招聘狗word简历"
Call tqsj2(MyDocument, i, jgarr)
Case "4猎聘word简历"
Set mytable = MyDocument.Tables(3)
lsJs = 0
For Each mycell In mytable.Range.Cells
lsJs = lsJs + 1
lsArr(lsJs) = qczf(mycell.Range.Text)
Next mycell
'jgArr(i, 1) = zL '简历名称
jgarr(i, 1) = lsArr(2) '姓名
jgarr(i, 2) = lsArr(2) '姓名
jgarr(i, 3) = lsArr(4) '性别
jgarr(i, 4) = lsArr(9) '出生年月
jgarr(i, 7) = lsArr(17) '婚姻状况
jgarr(i, 8) = lsArr(15) '工作经验
jgarr(i, 9) = lsArr(13) '学历
End Select
.ActiveDocument.Close
Next i
End With
jiesu:
Wdoc.Quit
'写入结果
Sheets("提取结果").Range("B2:az100000").ClearContents
Sheets("提取结果").Cells(2, 2).Resize(jgJs, 32) = jgarr
End Sub
Sub tqsj2(MyDocument, i, ByRef jgarr)
'tqsj2(MyDocumet, i, jgArr)
Dim lsArr(1 To 100) As String
Dim lsJs As Integer, ls_Text As String, ls_sZ As Integer
Dim lsZD '临时字典 key-单元格的值 item-序号
Dim bXh As Integer
Const fgf = " "
Set lsZD = CreateObject("scripting.dictionary")
Set mytable = MyDocument.Tables(1)
lsJs = 0
For Each mycell In mytable.Range.Cells
lsJs = lsJs + 1
lsArr(lsJs) = mycell.Range.Text
Next mycell
xm = Mid(lsArr(4), 1, InStr(lsArr(4), Space(1)) - 1)
jgarr(i, 1) = xm '姓名
jgarr(i, 2) = xm
arr = Split(lsArr(6), "|")
jgarr(i, 3) = Trim(arr(0))
jgarr(i, 4) = Mid(Trim(arr(3)), 1, InStr(Trim(arr(3)), "年")) '出生年月
jgarr(i, 7) = Trim(arr(1)) '婚姻状况
jgarr(i, 8) = lsArr(7) '工作经验
jgarr(i, 9) = Trim(arr(4)) '学历
'求职方向
Set mytable = MyDocument.Tables(3)
lsJs = 0: lsZD.RemoveAll
For Each mycell In mytable.Range.Cells
lsJs = lsJs + 1
lsArr(lsJs) = qczf2(mycell.Range.Text)
If Not lsZD.exists(lsArr(lsJs)) Then
lsZD.Add lsArr(lsJs), lsJs
End If
Next mycell
If lsZD.exists("期望地点") Then
jgarr(i, 12) = lsArr(lsZD("期望地点") + 1)
End If
'期望职位分解
If lsZD.exists("期望职位") Then
ls_Text = lsArr(lsZD("期望职位") + 1)
jgarr(i, 12) = wbfj(ls_Text)
End If
'职位性质
If lsZD.exists("工作性质") Then
jgarr(i, 10) = lsArr(lsZD("工作性质") + 1)
End If
If lsZD.exists("期望行业") Then
jgarr(i, 11) = lsArr(lsZD("期望行业") + 1)
End If
If lsZD.exists("期望薪资") Then
ls_Text = lsArr(lsZD("期望薪资") + 1)
If ls_Text <> "面议" Then
ls_sZ = Mid(ls_Text, 1, InStr(ls_Text, "-") - 1)
jgarr(i, 13) = xzfw(ls_sZ)
Else
jgarr(i, 13) = "面议"
End If
End If
'教育经历
Set mytable = MyDocument.Tables(5)
lsJs = 0
For Each mycell In mytable.Range.Cells
lsJs = lsJs + 1
lsArr(lsJs) = mycell.Range.Text
Next mycell
ls_Text = lsArr(1)
arr = Split(ls_Text, fgf) '中文空格分割
jgarr(i, 14) = arr(0) & "|" & qczf(arr(1)) & "|" & qczf(arr(2)) & "|" & qczf(arr(3))
'工作经历
'bXh = 7
'ls_Text = qczf2(MyDocumet.Tables(bXh).Range.Cells(1).Text)
Set mytable = MyDocument.Tables(7)
lsJs = 0
For Each mycell In mytable.Range.Cells
lsJs = lsJs + 1
lsArr(lsJs) = qczf2(mycell.Range.Text)
Next mycell
jgarr(i, 15) = lsArr(1)
For j = 2 To lsJs
jgarr(i, 15) = jgarr(i, 15) & "|" & lsArr(j)
Next j
End Sub
热心网友
时间：2023-05-20 07:40
用那个里面的代码稍微修改即可，具体看了word文件才知道。能搞定2个，就能搞定多个。
热心网友
时间：2023-05-20 07:40
思路一的实现：
Sub WordTablestoEXCEL()Dim WordDOC, CurDOC As Object
Dim TableCount, Table_i As Integer
Dim r, c, i As Integer
Set WordDOC = CreateObject("word.application")
mystr = Range("A1")
mypath = ThisWorkbook.Path & "\"
myname = mypath & "Doc1.docx"
Set CurDOC = WordDOC.documents.Open(myname)
WordDOC.Visible = False
TableCount = WordDOC.ActiveDocument.tables.Count
For Table_i = 1 To TableCount
CellsC = 0
For r = 1 To WordDOC.ActiveDocument.tables(Table_i).Rows.Count
CellsC = 0 '
For c = 1 To WordDOC.ActiveDocument.tables(Table_i).Columns.Count
On Error Resume Next
CellsC = CellsC + 1
findstr = WordDOC.ActiveDocument.tables(Table_i).Cell(r, c).Range.Text
findstr = Left(findstr, Len(findstr) - 1)
If findstr = mystr Then
Range("A2") = WordDOC.ActiveDocument.tables(Table_i).Cell(r, c+1).Range.Text
Range("A2") = Left(Range("A2"), Len(Range("A2")) - 1)
CurDOC.Close
Exit Sub
End If
Next c
Next r
Next Table_i
CurDOC.Close
End Sub
热心网友
时间：2023-05-20 07:41
要是能提供数据文件的话可以帮你做
热心网友
时间：2023-05-20 07:42
可以实现的，既然是改进，你肯定有基础代码了吧，私信发我看下的。
