告别手动复制粘贴!一键将Word所有表格导入Excel的VBA秘籍

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