怎么利用deepseek实现从Word文档自动提取信息到Excel工作表?
脚本之家
自从昨晚被deepseek秒杀后（详见：使用deepseek自动处理Excel工作表），整个人完全震惊了！真的有种多年的积累似乎是白学了的感觉！由此带来了各种各样的情绪，兴奋、不甘、不服气……
于是，今天晚上又试了一把。这次是想提高点难度，让Excel与Word互通，从多个Word文档中提取信息，看看deepseek能否给出满足我要求的代码。
我设定的场景也是非常实用的一个场景。如下图1所示，一个“个人简历表”模版。
图1
下面是两份填写好的简历示例，用作数据样例，如下图2和图3所示。
图2
图3
这些简历都存放在同一个文件夹中。现在，我们想要在Excel中汇总这些简历数据，以便于更好地分析和筛选。
试想一下，如果只有几份简历还好，如果有成百上千份简历，一份份录入数据，那是多么烦琐的事情，且又容易出错。这种情况最适合让程序代码来自动化实现了。
接下来，我让deepseek来帮我编写VBA代码。
打开deepseek网站，给DeepSeek发送消息，同时将图1所示的个人简历表模版上传附件。
我第一次的提问题如下图4所示。
图4
deepseek给出的代码并不能实现我的要求。我稍微调整了一下提问语句，如下图5所示。
图5
deepseek给出的代码还是不能实现我的要求。我检查了一下代码，确实是有问题。于是，我再次微调提问，如下图6所示。
图6
deepseek给出的代码仍不能实现我的要求。其代码只是取了表格中第2列的数据。此时，我有点得意了！哈哈，deepseek，你虽然给出了代码，确实帮我搭好了代码框架，但还是需要我来修改呀！
本打算开始自已修改代码，但转念一想，还是要让deepseek帮我完成。于是，我再次微调提问，提示deepseek“请反复思考几次！”如下图7所示。
图7
这次的代码看起来似乎符合要求了，但还是行不通！
继续修改提问。这次，我提示deepseek代码“后面的函数有问题，请再思考！”
图8
deepseek似乎终于想通了，或是把它给逼急了，终于给出了符合要求的代码，如下图9所示。
图9
完整的代码如下：
Sub ExtractResumeInfoToExcel()
Dim wdApp As Object
Dim wdDoc As Object
Dim ws As Worksheet
Dim folderPath As String
Dim fileName As String
Dim rowIndex As Integer
Dim colIndex As Integer
Dim fileDialog As fileDialog
Dim selectedFolder As Variant
Dim cellValue As String
' 初始化Excel工作表
Set ws = ThisWorkbook.Sheets(1)
ws.Cells.Clear
rowIndex = 2 ' 从第二行开始填充数据
colIndex = 1
' 设置标题行
ws.Cells(1, 1).Value = "姓名"
ws.Cells(1, 2).Value = "性别"
ws.Cells(1, 3).Value = "出生日期"
ws.Cells(1, 4).Value = "民族"
ws.Cells(1, 5).Value = "籍贯"
ws.Cells(1, 6).Value = "政治面貌"
ws.Cells(1, 7).Value = "婚姻状况"
ws.Cells(1, 8).Value = "健康状况"
ws.Cells(1, 9).Value = "兴趣爱好"
ws.Cells(1, 10).Value = "毕业院校及专业"
ws.Cells(1, 11).Value = "职业资格证书"
ws.Cells(1, 12).Value = "家庭地址"
ws.Cells(1, 13).Value = "联系电话"
ws.Cells(1, 14).Value = "工作经历"
ws.Cells(1, 15).Value = "获奖情况"
ws.Cells(1, 16).Value = "自我介绍"
' 打开文件夹选择对话框
Set fileDialog = Application.fileDialog(msoFileDialogFolderPicker)
With fileDialog
.Title = "请选择包含简历的文件夹"
If .Show = -1 Then
selectedFolder = .SelectedItems(1)
Else
MsgBox "未选择文件夹，操作取消。"
Exit Sub
End If
End With
folderPath = selectedFolder & "\"
fileName = Dir(folderPath & "*.docx")
' 初始化Word应用程序
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = False
' 遍历文件夹中的所有Word文档
Do While fileName <> ""
Set wdDoc = wdApp.Documents.Open(folderPath & fileName)
' 提取简历信息
For colIndex = 1 To 16
cellValue = ""
Select Case colIndex
Case 1
cellValue = wdDoc.Tables(1).cell(1, 2).Range.Text
Case 2
cellValue = wdDoc.Tables(1).cell(1, 4).Range.Text
Case 3
cellValue = wdDoc.Tables(1).cell(1, 6).Range.Text
Case 4
cellValue = wdDoc.Tables(1).cell(2, 2).Range.Text
Case 5
cellValue = wdDoc.Tables(1).cell(2, 4).Range.Text
Case 6
cellValue = wdDoc.Tables(1).cell(2, 6).Range.Text
Case 7
cellValue = wdDoc.Tables(1).cell(3, 2).Range.Text
Case 8
cellValue = wdDoc.Tables(1).cell(3, 4).Range.Text
Case 9
cellValue = wdDoc.Tables(1).cell(3, 6).Range.Text
Case 10
cellValue = wdDoc.Tables(1).cell(4, 2).Range.Text
Case 11
cellValue = wdDoc.Tables(1).cell(4, 4).Range.Text
Case 12
cellValue = wdDoc.Tables(1).cell(5, 2).Range.Text
Case 13
cellValue = wdDoc.Tables(1).cell(5, 4).Range.Text
Case 14
cellValue = wdDoc.Tables(1).cell(6, 2).Range.Text
Case 15
cellValue = wdDoc.Tables(1).cell(7, 2).Range.Text
Case 16
cellValue = wdDoc.Tables(1).cell(8, 2).Range.Text
End Select
' 去除多余的字符（如段落标记）
cellValue = Replace(cellValue, Chr(13), "")
cellValue = Replace(cellValue, Chr(7), "")
cellValue = Trim(cellValue)
' 将信息写入Excel工作表
ws.Cells(rowIndex, colIndex).Value = cellValue
Next colIndex
' 关闭当前Word文档
wdDoc.Close SaveChanges:=False
' 移动到下一行
rowIndex = rowIndex + 1
' 获取下一个文件名
fileName = Dir
Loop
' 关闭Word应用程序
wdApp.Quit
' 释放对象
Set wdDoc = Nothing
Set wdApp = Nothing
MsgBox "简历信息提取完成！"
End Sub新建一个Excel工作簿，按Alt+F11打开VBE，插入一个标准模块，在其中粘贴上面的代码，如下图10所示。
图10
然后运行代码，代码会弹出一个对话框，要求你选择简历所在的文件夹。示例结果如下图11所示。
图11
看来，对待deepseek也要有耐心！
作者：fanjy
来源：完美Excel