Sub ExtractMultipleResumesFromWord() Dim wdApp As Object, wdDoc As Object Dim ws As Worksheet Dim tableIndex As Long, rowNum As Long, i As Long Dim lastRow As Long Dim fileName As String Dim tableCount As Long, validTableCount As Long On Error GoTo ErrorHandler ' 设置Excel工作表 Set ws = ThisWorkbook.Sheets(1) ws.Cells.Clear rowNum = 2 ' 从第2行开始写入数据（第1行为标题行） ' 创建Word应用程序对象 Set wdApp = CreateObject("Word.Application") wdApp.Visible = False ' 设置为不可见以提高处理速度 ' 获取Word文件 fileName = Application.GetOpenFilename("Word文件 (*.doc;*.docx), *.doc;*.docx", , "选择包含多个简历的Word文件") If fileName = "False" Then Exit Sub ' 用户取消了选择 ' 打开Word文档 Set wdDoc = wdApp.Documents.Open(fileName) ' 检查文档中表格数量 tableCount = wdDoc.Tables.Count If tableCount = 0 Then MsgBox "文档中没有找到表格！", vbExclamation GoTo CleanUp End If ' 设置Excel标题行 SetExcelHeaders ws ' 遍历所有表格 For tableIndex = 1 To tableCount Dim currentTable As Object Set currentTable = wdDoc.Tables(tableIndex) ' 检查表格是否可能是简历表格（至少有5行2列） If currentTable.Rows.Count >= 5 And currentTable.Columns.Count >= 2 Then ' 提取当前表格中的简历信息 If ExtractResumeFromTable(currentTable, ws, rowNum) Then validTableCount = validTableCount + 1 rowNum = rowNum + 1 End If End If Next tableIndex ' 自动调整列宽 ws.Columns("A:Z").AutoFit MsgBox "完成！共找到 " & tableCount & " 个表格，成功提取 " & validTableCount & " 份简历。", vbInformationCleanUp: ' 清理对象 If Not wdDoc Is Nothing Then wdDoc.Close False Set wdDoc = Nothing End If If Not wdApp Is Nothing Then wdApp.Quit Set wdApp = Nothing End If Exit SubErrorHandler: MsgBox "发生错误: " & Err.Description, vbCritical GoTo CleanUpEnd Sub' 设置Excel标题行Sub SetExcelHeaders(ws As Worksheet) With ws .Cells(1, 1) = "姓名" .Cells(1, 2) = "出生年月" .Cells(1, 3) = "最高学历" .Cells(1, 4) = "毕业学校" .Cells(1, 5) = "专业" .Cells(1, 6) = "职称" .Cells(1, 7) = "邮箱" .Cells(1, 8) = "联系电话" .Cells(1, 9) = "现居住地" .Cells(1, 10) = "性别" .Cells(1, 11) = "年龄" .Cells(1, 12) = "工作年限" .Cells(1, 13) = "期望职位" .Cells(1, 14) = "期望薪资" .Cells(1, 15) = "籍贯" ' 设置标题行格式 With .Rows(1) .Font.Bold = True .Font.Color = RGB(255, 255, 255) .Interior.Color = RGB(44, 82, 130) .HorizontalAlignment = xlCenter End With End WithEnd Sub' 从单个表格中提取简历信息Function ExtractResumeFromTable(tbl As Object, ws As Worksheet, rowNum As Long) As Boolean On Error GoTo ExtractError Dim fieldDict As Object Set fieldDict = CreateObject("Scripting.Dictionary") ' 初始化字典，用于存储字段名和值 fieldDict.Add "姓名", "" fieldDict.Add "出生年月", "" fieldDict.Add "最高学历", "" fieldDict.Add "毕业学校", "" fieldDict.Add "专业", "" fieldDict.Add "职称", "" fieldDict.Add "邮箱", "" fieldDict.Add "联系电话", "" fieldDict.Add "现居住地", "" fieldDict.Add "性别", "" fieldDict.Add "年龄", "" fieldDict.Add "工作年限", "" fieldDict.Add "期望职位", "" fieldDict.Add "期望薪资", "" fieldDict.Add "籍贯", "" ' 遍历表格行，提取字段信息 Dim i As Long, j As Long For i = 1 To tbl.Rows.Count If tbl.Columns.Count >= 2 Then Dim fieldName As String, fieldValue As String ' 获取第一列的字段名 fieldName = CleanText(tbl.Cell(i, 1).Range.Text) fieldName = Replace(fieldName, ":", "") ' 去除冒号 fieldName = Replace(fieldName, "：", "") ' 去除中文冒号 fieldName = Trim(fieldName) ' 获取第二列的字段值 If tbl.Columns.Count >= 2 Then fieldValue = CleanText(tbl.Cell(i, 2).Range.Text) fieldValue = Trim(fieldValue) End If ' 根据字段名将值存入字典 If fieldDict.Exists(fieldName) Then fieldDict(fieldName) = fieldValue Else ' 尝试匹配部分字段名 MatchPartialFieldName fieldDict, fieldName, fieldValue End If End If Next i ' 将提取的信息写入Excel With ws .Cells(rowNum, 1) = fieldDict("姓名") .Cells(rowNum, 2) = fieldDict("出生年月") .Cells(rowNum, 3) = fieldDict("最高学历") .Cells(rowNum, 4) = fieldDict("毕业学校") .Cells(rowNum, 5) = fieldDict("专业") .Cells(rowNum, 6) = fieldDict("职称") .Cells(rowNum, 7) = fieldDict("邮箱") .Cells(rowNum, 8) = fieldDict("联系电话") .Cells(rowNum, 9) = fieldDict("现居住地") .Cells(rowNum, 10) = fieldDict("性别") .Cells(rowNum, 11) = fieldDict("年龄") .Cells(rowNum, 12) = fieldDict("工作年限") .Cells(rowNum, 13) = fieldDict("期望职位") .Cells(rowNum, 14) = fieldDict("期望薪资") .Cells(rowNum, 15) = fieldDict("籍贯") End With ExtractResumeFromTable = True Exit FunctionExtractError: ExtractResumeFromTable = False Exit FunctionEnd Function' 清理文本中的特殊字符Function CleanText(text As String) As String Dim result As String result = text ' 去除Word表格单元格末尾的特殊字符 result = Replace(result, Chr(13), "") ' 回车符 result = Replace(result, Chr(7), "") ' 特殊字符 result = Replace(result, Chr(10), "") ' 换行符 result = Replace(result, vbNewLine, "") ' 换行 result = Replace(result, vbCrLf, "") ' 回车换行 result = Replace(result, vbTab, "") ' 制表符 ' 去除首尾空格 result = Trim(result) ' 如果有多个连续空格，替换为单个空格 While InStr(result, " ") > 0 result = Replace(result, " ", " ") Wend CleanText = resultEnd Function' 匹配部分字段名（处理字段名略有差异的情况）Sub MatchPartialFieldName(dict As Object, fieldName As String, fieldValue As String) Dim key As Variant ' 定义字段名可能的变体 For Each key In dict.Keys Select Case key Case "姓名" If InStr(fieldName, "姓") > 0 And InStr(fieldName, "名") > 0 Then dict(key) = fieldValue Exit Sub End If Case "出生年月" If InStr(fieldName, "出生") > 0 Or InStr(fieldName, "生日") > 0 Then dict(key) = fieldValue Exit Sub End If Case "最高学历" If InStr(fieldName, "学历") > 0 Or InStr(fieldName, "学位") > 0 Then dict(key) = fieldValue Exit Sub End If Case "毕业学校" If InStr(fieldName, "学校") > 0 Or InStr(fieldName, "院校") > 0 Or InStr(fieldName, "毕业") > 0 Then dict(key) = fieldValue Exit Sub End If Case "专业" If fieldName = "专业" Or fieldName = "所学专业" Then dict(key) = fieldValue Exit Sub End If Case "职称" If fieldName = "职称" Or fieldName = "职位" Or fieldName = "职务" Then dict(key) = fieldValue Exit Sub End If Case "邮箱" If InStr(fieldName, "邮箱") > 0 Or InStr(fieldName, "邮件") > 0 Or InStr(fieldName, "E-mail") > 0 Then dict(key) = fieldValue Exit Sub End If Case "联系电话" If InStr(fieldName, "电话") > 0 Or InStr(fieldName, "手机") > 0 Or InStr(fieldName, "联系") > 0 Then dict(key) = fieldValue Exit Sub End If Case "现居住地" If InStr(fieldName, "居住") > 0 Or InStr(fieldName, "地址") > 0 Or InStr(fieldName, "住址") > 0 Then dict(key) = fieldValue Exit Sub End If Case "性别" If fieldName = "性别" Then dict(key) = fieldValue Exit Sub End If Case "年龄" If fieldName = "年龄" Then dict(key) = fieldValue Exit Sub End If Case "工作年限" If InStr(fieldName, "工作年限") > 0 Or InStr(fieldName, "经验") > 0 Then dict(key) = fieldValue Exit Sub End If Case "期望职位" If InStr(fieldName, "期望") > 0 And InStr(fieldName, "职位") > 0 Then dict(key) = fieldValue Exit Sub End If Case "期望薪资" If InStr(fieldName, "期望") > 0 And InStr(fieldName, "薪资") > 0 Then dict(key) = fieldValue Exit Sub End If Case "籍贯" If fieldName = "籍贯" Or fieldName = "户口" Or fieldName = "户籍" Then dict(key) = fieldValue Exit Sub End If End Select Next keyEnd Sub' 批量处理多个Word文件Sub BatchProcessWordFiles() Dim wdApp As Object, wdDoc As Object Dim ws As Worksheet Dim filePath As String, fileName As String Dim tableIndex As Long, rowNum As Long Dim fileCount As Long, totalResumeCount As Long Dim fso As Object, folder As Object, file As Object On Error GoTo ErrorHandler ' 设置Excel工作表 Set ws = ThisWorkbook.Sheets(1) ws.Cells.Clear rowNum = 2 ' 从第2行开始写入数据 ' 创建Word应用程序对象 Set wdApp = CreateObject("Word.Application") wdApp.Visible = False ' 获取文件夹路径 Dim folderPath As String With Application.FileDialog(msoFileDialogFolderPicker) .Title = "选择包含Word文件的文件夹" If .Show <> -1 Then Exit Sub folderPath = .SelectedItems(1) End With ' 创建文件系统对象 Set fso = CreateObject("Scripting.FileSystemObject") Set folder = fso.GetFolder(folderPath) ' 设置Excel标题行 SetExcelHeaders ws ' 遍历文件夹中的所有Word文件 For Each file In folder.Files fileName = file.Name filePath = file.Path ' 检查文件扩展名 If LCase(Right(fileName, 4)) = ".doc" Or LCase(Right(fileName, 5)) = ".docx" Then fileCount = fileCount + 1 ' 打开Word文档 Set wdDoc = wdApp.Documents.Open(filePath) ' 遍历文档中的所有表格 For tableIndex = 1 To wdDoc.Tables.Count Dim currentTable As Object Set currentTable = wdDoc.Tables(tableIndex) ' 检查表格是否可能是简历表格 If currentTable.Rows.Count >= 5 And currentTable.Columns.Count >= 2 Then ' 提取当前表格中的简历信息 If ExtractResumeFromTable(currentTable, ws, rowNum) Then ' 在Excel中添加文件名作为参考 ws.Cells(rowNum, 16) = fileName ws.Cells(rowNum, 17) = "表格" & tableIndex totalResumeCount = totalResumeCount + 1 rowNum = rowNum + 1 End If End If Next tableIndex ' 关闭文档 wdDoc.Close False End If Next file ' 自动调整列宽 ws.Columns("A:Q").AutoFit MsgBox "完成！共处理 " & fileCount & " 个Word文件，提取 " & totalResumeCount & " 份简历。", vbInformationCleanUp: ' 清理对象 If Not wdApp Is Nothing Then wdApp.Quit Set wdApp = Nothing End If Exit SubErrorHandler: MsgBox "发生错误: " & Err.Description, vbCritical GoTo CleanUpEnd Sub' 创建简易用户界面Sub ShowResumeExtractorUI() Dim response As Integer response = MsgBox("请选择操作方式：" & vbCrLf & vbCrLf & _ "是(Y) - 处理单个Word文件（文件中有多份简历）" & vbCrLf & _ "否(N) - 批量处理文件夹中的多个Word文件" & vbCrLf & _ "取消 - 退出", vbYesNoCancel + vbQuestion, "简历提取工具") Select Case response Case vbYes ExtractMultipleResumesFromWord Case vbNo BatchProcessWordFiles Case vbCancel ' 用户取消，不做任何操作 End SelectEnd Sub
