怎么利用deepseek实现从Word文档自动提取信息到Excel工作表?

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