前天收到一位网友的求助，大致意思是：需要经常从一个大的excel信息汇总表中获取到数据，然后生成几个固定的格式的表单，希望使用VBA实现查找特定使用单位名称后，能够自动获取并在表单中填写对应的信息。
具体如下（我将示例数据进行了修改，应该不会侵犯那位朋友的隐私。若有，请给我留言，我将立即删除）：
如下图1所示的“信息总表”工作表中，汇总有完整的数据。
我理解他的意图是，从“信息总表”中提取数据自动填写到“委托单”中带有“自动获取”字样的单元格，且有多少条数据就填写多少个委托单。考虑到其需求，我想自动生成一个新工作簿，包含所查找的特定数据的所有“委托单”。
刚开始，我认为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
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所示。生成了一个包含所查找的数据的所有委托单的工作簿，并自动填写了相应的信息。
但我并没有结束，我想看看deepseek是怎么修改的。于是，我接着向它提问：
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最初生成的代码并对其进行了稍微的修改，将新建工作簿保存在与当前工作簿相同的文件夹下。最终代码如下：
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一些知识的。
粤ICP备14082021号
免费POC，
零成本试错
