VBA应用

02 工作簿

按选择的名单批量创建包含某个指定模版表的工作簿

用Excel_VBA，按指定的名单，可以批量创建工作簿，当需要创建的工作簿有固定模版时，当然也可以把模版放置到批量创建的新工作表中！

需要注意几个可能发生的错误处理的过程预处理

1、选择单元格区域为空时怎么处理？
2、选择或输入的模版表名称错误，并不存在怎么办？

如图所示，按照工作表的名单和选择的模版表，在当前工作簿中批量创建工作簿：

运行视频：

源码下载：

描述：

按选择的名单批量创建包含某个指定模版表的工作簿

VBA实现过程：

1.user_input = InputBox()，弹出一个交互窗口，返回用户输入的内容；
2.result_arr = Split(user_input, ",")，split(字符串，分割符)，返回一个数组；
3.Set sht = ThisWorkbook.Sheets(表名称)，如果工作簿内不存在该表，则会返回一个错误，在这之前有 On Error Resume Next，错误仍然执行的语句，所以并不会中止，反而紧跟着是否有错误，可以用来判断是否存在该表，注意每次循环到这之前都需要Err.Clear，将错误清除；
4.两个循环嵌套，一个是循环在当前路径创建新的工作簿，另一个是循环将选择的模版表逐一复制到新工作簿中。

示例代码

复制成功!


Sub 工作表名单批量创建包含指定模版的工作簿()

    Dim Name_list, rng As Range
    Dim Str_name As String
    Dim Act_name, Err_sht_name, file_path, sheet_list, user_input As String
    Dim newWb As Workbook
    Dim sht As Worksheet
    Dim select_items As Variant
    Dim result_arr As Variant
    Dim i As Integer
    Dim mod_sht As New Collection


    file_path = ThisWorkbook.Path & "\"               '获取当前工作簿所在完整路径


    On Error Resume Next                                '在错误发生时，仍可以继续运行
    Set Name_list = Application.InputBox("选择工作表名单", "提示_", Type:=8)          '选择工作表名单
    If Err.Number > 0 Then MsgBox "未选择内容": Exit Sub                              '未选择时退出
    If WorksheetFunction.CountA(Name_list) = 0 Then MsgBox "选择的内容为空": Exit Sub '选择的单元格区域内容都是空时也退出
    Act_name = Name_list.Parent.Name                     '获取选择的名单所在的工作表


    For Each sht In ThisWorkbook.Worksheets             '创建工作表列表字符串，不包含名单所在的工作表
        If sht.Name <> Act_name Then
            sheet_list = sheet_list & sht.Name & ","
        End If
    Next sht
    sheet_list = Left(sheet_list, Len(sheet_list) - 1) ' 移除最后一个逗号

    '弹出一个窗体，提供所有的模版表供选择、输入的参考
    user_input = InputBox("请输入模版表名称（用逗号分隔多个模版表）：" & vbNewLine & _
                        "可用模版表：" & vbNewLine & sheet_list, _
                        "选择模版表", sheet_list)
    result_arr = Split(user_input, ",")                 '","分割选择或输入的模版表名称

    '避免选择或输入的模版表错误，这里增加一个判断，当选择或输入的模版表不存在时，弹出提示
    For i = 0 To UBound(result_arr)
        Err.Clear
        Set sht = ThisWorkbook.Sheets(result_arr(i))
        If Err.Number > 0 Then
            Err_sht_name = Err_sht_name & "," & result_arr(i)
        Else
            mod_sht.Add result_arr(i)
        End If
    Next i
    If Len(Err_sht_name) > 0 Then MsgBox "注意：选择模版表错误，以下模版表不存在" & vbNewLine & Err_sht_name & vbNewLine & "最终批量创建的工作簿也不会包含该模版！"


    ' 禁用屏幕更新和警告
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False


    For Each rng In Name_list                           '遍历名单
        Str_name = rng.Value                            '单元格内容赋值作为工作表名称
        If Len(Str_name) Then                           '如果名称非空
            Err.Clear
            Set newWb = Workbooks.Add                   '新建一个工作簿
            newWb.SaveAs Filename:=file_path & Str_name & ".xlsx"   '保存工作簿在当前路径下，名字用名单的名字

            If mod_sht.Count > 0 Then                   '当模版表不为空时，执行“复制所选择的模版表，到新的工作簿中”
                For i = 1 To mod_sht.Count
                    newWb.Worksheets.Add after:=newWb.Sheets(newWb.Sheets.Count)
                    newWb.ActiveSheet.Name = mod_sht(i)
                    ThisWorkbook.Sheets(mod_sht(i)).Cells.Copy
                    newWb.Sheets(mod_sht(i)).Paste        '新表粘贴
                Next i
                newWb.Sheets(1).Delete                   '删除第一个工作表，也是新增工作簿时默认的首张表
            End If


            newWb.Close SaveChanges:=True              '保存关闭新工作簿

        End If
    Next rng

    ' 恢复屏幕更新和警告
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    MsgBox "工作簿批量创建完成"  '过程结束告知！

End Sub