我要投稿

使用deepseek自动填写Excel工作表信息

发布日期：2025-02-12 17:01:11 浏览次数： 2019 来源：完美Excel

标签：AI，大模型，deepseek，VBA

前天收到一位网友的求助，大致意思是：需要经常从一个大的excel信息汇总表中获取到数据，然后生成几个固定的格式的表单，希望使用VBA实现查找特定使用单位名称后，能够自动获取并在表单中填写对应的信息。

具体如下（我将示例数据进行了修改，应该不会侵犯那位朋友的隐私。若有，请给我留言，我将立即删除）：

如下图1所示的“信息总表”工作表中，汇总有完整的数据。

图1

下图2为固定格式的表单。

图2

我理解他的意图是，从“信息总表”中提取数据自动填写到“委托单”中带有“自动获取”字样的单元格，且有多少条数据就填写多少个委托单。考虑到其需求，我想自动生成一个新工作簿，包含所查找的特定数据的所有“委托单”。

刚开始，我认为deepseek应该不大可能会处理这样的问题，于是自己编写了一段VBA代码来实现。但是，我还是太低估了deepseek的能力！

昨天晚上，我还是想让deepseek试试，看它能否完成这样的需求。

经过几次试提问题答复不满意后，我再一次修正，向deepseek提问如下：

附件中有一个包含两个工作表的工作簿，工作表“信息总表”中包含一系列数据，工作表“委托单”是一个模版。我想新建一个工作簿，其工作表以“委托单”为模版，然后在原工作簿的“信息总表”的列A中查找特定的使用单位，查找到多少条使用单位就在刚才新建的工作簿中创建几个工作表，例如查找“完美生活服务集团股份有限公司”有2条，则在新工作簿中以“委托单”为模版创建2个工作表，并将相关行信息分别填入这些工作表中带有 “自动获取”字样的单元格中，“自动获取”字样的单元格中填入的数据为其左侧单元格中的数据在“信息总表”中查找的结果。请帮我使用VBA实现。

同时，我上传示例工作簿作为附件。

deepseek给出了它的思考过程，比较符合我的意图。同时，给出的代码如下：

Sub GenerateCommissionSheets() Dim srcWB As Workbook, newWB As Workbook Dim infoSheet As Worksheet, templateSheet As Worksheet Dim criteria As String, lastRow As Long, i As Long Dim matchedRows As New Collection Dim headerRow As Range, targetSheet As Worksheet Dim cell As Range, leftCell As Range, colIndex As Variant
 Set srcWB = ThisWorkbook ' 假设代码在当前工作簿运行 Set infoSheet = srcWB.Sheets("信息总表") Set templateSheet = srcWB.Sheets("委托单")
 ' 获取用户输入的使用单位 criteria = InputBox("请输入要筛选的使用单位名称：", "输入筛选条件") If criteria = "" Then Exit Sub
 ' 在信息总表中查找匹配行 With infoSheet   lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow ' 假设第1行为标题行     If .Cells(i, 1).Value = criteria Then matchedRows.Add i Next i End With
 If matchedRows.Count = 0 Then   MsgBox "未找到匹配的使用单位记录。", vbInformation Exit Sub End If
 ' 创建新工作簿 Set newWB = Workbooks.Add Application.DisplayAlerts = False While newWB.Sheets.Count > 1 newWB.Sheets(1).Delete Wend Application.DisplayAlerts = True
 ' 为每个匹配行创建委托单 For Each Item In matchedRows   templateSheet.Copy Before:=newWB.Sheets(1) Set targetSheet = newWB.Sheets(1) With targetSheet     .Name = "委托单" & newWB.Sheets.Count ' 查找所有自动获取单元格 For Each cell In .UsedRange       If cell.Value Like "*自动获取*" Then         Set leftCell = cell.Offset(0, -1)         colIndex = Application.Match(leftCell.Value, infoSheet.Rows(1), 0)
         If Not IsError(colIndex) Then           cell.Value = infoSheet.Cells(Item, colIndex).Value Else cell.Value = "数据未找到" End If End If Next cell End With Next Item
 ' 删除初始空白表并整理工作簿 newWB.Sheets(1).Delete newWB.Sheets(1).Activate newWB.SaveAs Filename:=Environ("USERPROFILE") & "\Desktop\" & criteria & "委托单.xlsx" MsgBox "已生成 " & matchedRows.Count & " 张委托单！", vbInformationEnd Sub

很好！基本实现了我的意图。但是有两点小瑕疵：

1.Item变量未定义。

2.newWB.Sheets(1).Delete不是删除在新建工作簿时自带的空工作表，而是将新添加的填写了信息的工作表给删除了。

我对其进行了调整后，代码实现了我需要的功能。我修改后的代码如下：

Sub GenerateCommissionSheetsPlus() Dim srcWB As Workbook, newWB As Workbook Dim infoSheet As Worksheet, templateSheet As Worksheet Dim criteria As String, lastRow As Long, i As Long Dim matchedRows As New Collection Dim Item As Variant Dim headerRow As Range, targetSheet As Worksheet Dim cell As Range, leftCell As Range, colIndex As Variant
 Set srcWB = ThisWorkbook ' 假设代码在当前工作簿运行 Set infoSheet = srcWB.Sheets("信息总表") Set templateSheet = srcWB.Sheets("委托单")
 ' 获取用户输入的使用单位 criteria = InputBox("请输入要筛选的使用单位名称：", "输入筛选条件") If criteria = "" Then Exit Sub
 ' 在信息总表中查找匹配行 With infoSheet   lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow ' 假设第1行为标题行     If .Cells(i, 1).Value = criteria Then matchedRows.Add i   Next i End With
 If matchedRows.Count = 0 Then   MsgBox "未找到匹配的使用单位记录。", vbInformation Exit Sub End If
 ' 创建新工作簿 Set newWB = Workbooks.Add Application.DisplayAlerts = False While newWB.Sheets.Count > 1 newWB.Sheets(1).Delete Wend Application.DisplayAlerts = True
 ' 为每个匹配行创建委托单 For Each Item In matchedRows   templateSheet.Copy after:=newWB.Sheets(Worksheets.Count)   Set targetSheet = newWB.Sheets(Worksheets.Count) With targetSheet     .Name = "委托单" & newWB.Sheets.Count - 1 ' 查找所有自动获取单元格 For Each cell In .UsedRange       If cell.Value Like "*自动获取*" Then         Set leftCell = cell.Offset(0, -1)         colIndex = Application.Match(leftCell.Value, infoSheet.Rows(1), 0)
         If Not IsError(colIndex) Then           cell.Value = infoSheet.Cells(Item, colIndex).Value Else cell.Value = "数据未找到" End If End If Next cell End With Next Item
 ' 删除初始空白表并整理工作簿 newWB.Sheets(1).Delete newWB.Sheets(1).Activate newWB.SaveAs Filename:=Environ("USERPROFILE") & "\Desktop\" & criteria & "委托单.xlsx" MsgBox "已生成 " & matchedRows.Count & " 张委托单！", vbInformationEnd Sub

运行后的结果如下图3所示。生成了一个包含所查找的数据的所有委托单的工作簿，并自动填写了相应的信息。

图3

但我并没有结束，我想看看deepseek是怎么修改的。于是，我接着向它提问：

上述代码调试时显示Item变量未定义，请帮我修改

deepseek仔细检查了代码并进行了修正和优化。这次给出的代码如下：

Sub GenerateCommissionSheets() Dim srcWB As Workbook, newWB As Workbook Dim infoSheet As Worksheet, templateSheet As Worksheet Dim criteria As String, lastRow As Long, i As Long Dim matchedRows As New Collection Dim headerRow As Range, targetSheet As Worksheet Dim cell As Range, leftCell As Range, colIndex As Variant Dim rowNum As Variant ' 声明循环变量
 Set srcWB = ThisWorkbook Set infoSheet = srcWB.Sheets("信息总表") Set templateSheet = srcWB.Sheets("委托单")
 criteria = InputBox("请输入要筛选的使用单位名称：", "输入筛选条件") If criteria = "" Then Exit Sub
 ' 查找匹配行（优化空值处理） With infoSheet   lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow     If Trim(.Cells(i, 1).Value) = criteria Then      matchedRows.Add i End If Next i End With
 If matchedRows.Count = 0 Then   MsgBox "未找到匹配的使用单位记录。", vbInformation Exit Sub End If
 ' 创建新工作簿（增加错误处理） On Error Resume Next Set newWB = Workbooks.Add Application.DisplayAlerts = False Do While newWB.Sheets.Count > 1 newWB.Sheets(1).Delete Loop Application.DisplayAlerts = True
 ' 生成委托单（优化命名逻辑） For Each rowNum In matchedRows   templateSheet.Copy Before:=newWB.Sheets(1) Set targetSheet = newWB.Sheets(1) With targetSheet     .Name = Left("委托单_" & criteria, 25) & "_" & (newWB.Sheets.Count - 1)
 ' 增强字段匹配逻辑 For Each cell In .UsedRange       If InStr(cell.Value, "自动获取") > 0 Then         Set leftCell = cell.Offset(0, -1)         colIndex = Application.Match(Trim(leftCell.Value), infoSheet.Rows(1), 0)
         If Not IsError(colIndex) Then ' 处理日期格式           If IsDate(infoSheet.Cells(rowNum, colIndex).Value) Then             cell.Value = Format(infoSheet.Cells(rowNum, colIndex).Value, "yyyy-mm-dd") Else             cell.Value = infoSheet.Cells(rowNum, colIndex).Value End If Else cell.Value = "字段匹配失败" End If End If Next cell   End With Next rowNum
 ' 保存优化（处理特殊字符） newWB.Sheets(1).Delete newWB.Sheets(1).Activate newWB.SaveAs Filename:=Environ("USERPROFILE") & "\Desktop\" & _   Replace(criteria, "/", "-") & "委托单.xlsx", _ FileFormat:=xlOpenXMLWorkbook MsgBox "成功生成 " & matchedRows.Count & " 张委托单！", vbInformationEnd Sub

变量问题解决了，代码也进行了优化，但仍然存在1个未解决的问题：

newWB.Sheets(1).Delete不是删除在新建工作簿时自带的空工作表，而是将新添加的填写了信息的工作表给删除了。

我接着向deepseek提问：

上面的代码把不该删除的工作表给删除了，也就是新工作簿中已生成的工作表删除了而空工作表没有删除，请完善代码

这次虽然给出了修正，但又带来了新的问题，“委托单”填写的数量也有问题。本来还可以再接着问的，但我想我前面已经实现了我需要的功能，自己调整一下代码就行了，不想再花费时间试了。

最后，我选取了deepseek最初生成的代码并对其进行了稍微的修改，将新建工作簿保存在与当前工作簿相同的文件夹下。最终代码如下：

Sub GenerateCommissionSheetsPlus() Dim srcWB As Workbook, newWB As Workbook Dim infoSheet As Worksheet, templateSheet As Worksheet Dim criteria As String, lastRow As Long, i As Long Dim matchedRows As New Collection Dim Item As Variant Dim headerRow As Range, targetSheet As Worksheet Dim cell As Range, leftCell As Range, colIndex As Variant
 Set srcWB = ThisWorkbook ' 假设代码在当前工作簿运行 Set infoSheet = srcWB.Sheets("信息总表") Set templateSheet = srcWB.Sheets("委托单")
 ' 获取用户输入的使用单位 criteria = InputBox("请输入要筛选的使用单位名称：", "输入筛选条件") If criteria = "" Then Exit Sub
 ' 在信息总表中查找匹配行 With infoSheet   lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow ' 假设第1行为标题行     If .Cells(i, 1).Value = criteria Then matchedRows.Add i Next i End With
 If matchedRows.Count = 0 Then   MsgBox "未找到匹配的使用单位记录。", vbInformation Exit Sub End If
 ' 创建新工作簿 Set newWB = Workbooks.Add Application.DisplayAlerts = False While newWB.Sheets.Count > 1 newWB.Sheets(1).Delete Wend Application.DisplayAlerts = True
 ' 为每个匹配行创建委托单 For Each Item In matchedRows   templateSheet.Copy after:=newWB.Sheets(Worksheets.Count)   Set targetSheet = newWB.Sheets(Worksheets.Count) With targetSheet     .Name = "委托单" & newWB.Sheets.Count - 1 ' 查找所有自动获取单元格 For Each cell In .UsedRange       If cell.Value Like "*自动获取*" Then       Set leftCell = cell.Offset(0, -1)       colIndex = Application.Match(leftCell.Value, infoSheet.Rows(1), 0)
       If Not IsError(colIndex) Then         cell.Value = infoSheet.Cells(Item, colIndex).Value Else cell.Value = "数据未找到" End If End If Next cell End With Next Item
 ' 删除初始空白表并整理工作簿 newWB.Sheets(1).Delete newWB.Sheets(1).Activate MsgBox "已生成 " & matchedRows.Count & " 张委托单！", vbInformation newWB.SaveAs Filename:=ThisWorkbook.Path & "\" & criteria & "委托单.xlsx" newWB.Close SaveChanges:=TrueEnd Sub

看来，要想让deepseek帮助编写VBA代码，除了要有完整的提问外，还是要懂得VBA一些知识的。

53AI，企业落地大模型首选服务商

产品：场景落地咨询+大模型应用平台+行业解决方案

承诺：免费场景POC验证，效果验证后签署服务协议。零风险落地应用大模型，已交付160+中大型企业