夜雨聆风一键批量生成Excel工作簿！这个VBA工具真的太实用了
告别重复劳动，轻松搞定批量创建工作簿
在日常工作中，你是否经常遇到这样的场景：需要根据同一个模板，创建几十甚至上百个结构相同、但命名不同的Excel工作簿？比如：
• 为每个班级生成一份成绩分析表 • 为每个项目生成一份进度跟踪表 • 为每个客户生成一份报价单……
手动一个一个复制、改名、保存，不仅效率低下，还容易出错。今天，我们就分享一个自制的VBA批量创建工作簿工具，让你一键搞定批量生成，从此告别重复劳动！
🎯 工具功能简介
这个工具以Excel VBA窗体形式呈现，操作界面简洁直观。你只需要：
1. 准备一个模板文件（包含一个名为“模板”的工作表，以及一个名为“命名”的列表） 2. 选择输出目录 3. 点击按钮，即可自动生成以列表中名称为文件名的多个独立工作簿，每个工作簿都基于模板复制而来。
🖥️ 界面预览
窗体包含以下主要元素：
• 模板文件路径：显示已选择的模板文件 • 浏览按钮：选择模板文件 • 输出目录：显示保存位置 • 选择目录按钮：设置输出文件夹 • 命名预览列表：展示从“命名”工作表读取的所有工作簿名称 • 开始创建按钮：一键执行批量生成 • 状态栏：实时反馈操作进度和结果
📋 使用前准备
1. 模板文件的要求
你的模板文件（例如 模板.xlsx）中必须包含两个工作表：
模板 | |
命名 |
“命名”表示例：
⚠️ 注意：名称中不能包含
\/:*?"<>|等非法文件名字符。
核心代码：
Private Sub Btn浏览_Click()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.Filters.Clear
fd.Filters.Add "Excel文件", "*.xlsx;*.xlsm;*.xls"
fd.Title = "请选择模板文件"
If fd.Show = -1 Then
str模板路径 = fd.SelectedItems(1)
Tb文件路径.Value = str模板路径
Lbl文件名.Caption = "当前文件：" & GetFileName(str模板路径)
Call 验证文件
End If
End Sub
Private Sub Btn选择目录_Click()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "请选择输出目录"
If fd.Show = -1 Then
str输出目录 = fd.SelectedItems(1)
Tb输出目录.Value = str输出目录
End If
End Sub
Private Sub Btn开始创建_Click()
On Error GoTo ErrHandler
If str模板路径 = "" Then
Lbl状态.Caption = "请先选择模板文件！"
Exit Sub
End If
If str输出目录 = "" Then
str输出目录 = ThisWorkbook.Path
Tb输出目录.Value = str输出目录
End If
If UBound(arr名称, 1) = 0 Then
Lbl状态.Caption = "命名工作表中没有数据！"
Exit Sub
End If
Lbl状态.Caption = "正在创建工作簿..."
Btn开始创建.Enabled = False
Dim i As Long, j As Long
Dim wb新 As Workbook
Dim ws新 As Worksheet
Dim str新文件名 As String
Dim str完整路径 As String
Dim int成功 As Long, int失败 As Long
Dim str错误信息 As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb模板 = Workbooks.Open(str模板路径, ReadOnly:=True)
Set ws模板 = wb模板.Worksheets("模板")
For i = LBound(arr名称, 1) To UBound(arr名称, 1)
str新文件名 = arr名称(i, 1) & ".xlsx"
str完整路径 = str输出目录 & "\" & str新文件名
On Error Resume Next
Set wb新 = Workbooks.Add
If Err.Number <> 0 Then
int失败 = int失败 + 1
str错误信息 = str错误信息 & vbCrLf & arr名称(i, 1) & "：创建工作簿失败"
Err.Clear
GoTo NextLoop
End If
On Error Resume Next
ws模板.Copy Before:=wb新.Sheets(1)
If Err.Number <> 0 Then
wb新.Close False
int失败 = int失败 + 1
str错误信息 = str错误信息 & vbCrLf & arr名称(i, 1) & "：复制模板失败"
Err.Clear
GoTo NextLoop
End If
On Error Resume Next
For j = wb新.Sheets.Count To 1 Step -1
If wb新.Sheets(j).Name <> "Sheet" And wb新.Sheets(j).Name <> ws模板.Name Then
wb新.Sheets(j).Delete
End If
Next j
If Err.Number <> 0 Then
Err.Clear
End If
On Error Resume Next
wb新.SaveAs Filename:=str完整路径, FileFormat:=xlOpenXMLWorkbook
If Err.Number <> 0 Then
wb新.Close False
int失败 = int失败 + 1
str错误信息 = str错误信息 & vbCrLf & arr名称(i, 1) & "：保存失败"
Err.Clear
GoTo NextLoop
End If
wb新.Close True
int成功 = int成功 + 1
NextLoop:
Next i
wb模板.Close False
Set wb模板 = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
If MsgBox("创建完成！成功：" & int成功 & " 个，失败：" & int失败 & " 个" & vbCrLf & "是否打开保存目录？", vbYesNo + vbInformation, "批量创建工作簿") = vbYes Then
Shell "explorer.exe " & str输出目录, vbNormalFocus
End If
Lbl状态.Caption = "创建完成！成功：" & int成功 & " 个，失败：" & int失败 & " 个"
If int失败 > 0 Then
LogPrint "创建失败记录：" & str错误信息
End If
Btn开始创建.Enabled = True
Exit Sub
ErrHandler:
LogPrint "Btn开始创建_Click错误：" & Err.Description
Lbl状态.Caption = "执行出错：" & Err.Description
Btn开始创建.Enabled = True
If Not wb模板 Is Nothing Then wb模板.Close False
Set wb模板 = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Sub UserForm_Initialize()
Lbl状态.Caption = "准备就绪"
End Sub
Private Sub 验证文件()
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Set wb模板 = Workbooks.Open(str模板路径, ReadOnly:=True)
On Error Resume Next
Set ws模板 = wb模板.Worksheets("模板")
If ws模板 Is Nothing Then
MsgBox "模板文件缺少名为""模板""的工作表！", vbExclamation
wb模板.Close False
Set wb模板 = Nothing
Lbl文件名.Caption = "当前文件：文件验证失败"
Application.ScreenUpdating = True
Exit Sub
End If
Set ws命名 = wb模板.Worksheets("命名")
If ws命名 Is Nothing Then
MsgBox "模板文件缺少名为""命名""的工作表！", vbExclamation
wb模板.Close False
Set wb模板 = Nothing
Lbl文件名.Caption = "当前文件：文件验证失败"
Application.ScreenUpdating = True
Exit Sub
End If
Dim lastRow As Long
lastRow = ws命名.Cells(ws命名.Rows.Count, "A").End(xlUp).Row
If lastRow < 2 Then
MsgBox "命名工作表A列第2行开始没有数据！", vbExclamation
wb模板.Close False
Set wb模板 = Nothing
Lbl文件名.Caption = "当前文件：文件验证失败"
Application.ScreenUpdating = True
Exit Sub
End If
arr名称 = ws命名.Range("A2:A" & lastRow).Value
wb模板.Close False
Set wb模板 = Nothing
Lb预览.Clear
Dim i As Long
For i = LBound(arr名称, 1) To UBound(arr名称, 1)
Lb预览.AddItem i - 1
Lb预览.List(i - 1, 0) = i
Lb预览.List(i - 1, 1) = arr名称(i, 1)
Next i
Lbl文件名.Caption = "当前文件：" & GetFileName(str模板路径) & "（共 " & UBound(arr名称, 1) & " 个）"
Lbl状态.Caption = "文件验证通过,请设置输出目录后点击""开始创建"""
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
LogPrint "验证文件错误：" & Err.Description
Lbl文件名.Caption = "当前文件：验证出错"
If Not wb模板 Is Nothing Then wb模板.Close False
Set wb模板 = Nothing
Application.ScreenUpdating = True
End Sub
Private Function GetFileName(ByVal fullPath As String) As String
Dim i As Long
For i = Len(fullPath) To 1 Step -1
If Mid(fullPath, i, 1) = "\" Or Mid(fullPath, i, 1) = "/" Then
GetFileName = Mid(fullPath, i + 1)
Exit Function
End If
Next i
GetFileName = fullPath
End Function注意：上述代码中的
LogPrint过程需要你自己定义（例如写入文本文件或直接注释掉）。如果不需要日志功能，可以将所有LogPrint行删除或替换为Debug.Print。
⚠️ 注意事项
1. 工作表名称严格匹配
模板文件中必须包含名为 “模板” 和 “命名” 的工作表，一个字母都不能错。2. 名称合法性
“命名”表中的名称不能包含以下任何字符：\ / : * ? " < > |。否则保存时会报错。3. 文件格式
生成的工作簿默认保存为.xlsx格式。4. 性能
如果一次生成几百个工作簿，建议先关闭其他Excel程序，并确保电脑内存充足。
🎁 获取完整工程文件
如果你希望直接拿到已配置好的窗体文件，欢迎关注本公众号，在后台回复关键词 ：26051900 获取下载链接（包含完整Excel示例文件）。
📢 结语
这个VBA小工具虽然代码不长，却能实实在在提升工作效率。希望它能成为你办公自动化工具箱中的一员。如果你在使用过程中遇到任何问题，或有改进建议，欢迎在评论区留言交流。
相关文章推荐
告别手动重命名！这个Excel小工具，批量加前缀/后缀一键搞定
喜欢本文，就点个“在看”吧！ 👇