VBA应用

02 工作簿

在当前路径下按选择的名单批量创建或删除工作簿

用Excel_VBA，按指定的名单，可以批量创建工作簿、工作表、Word文档等等。

批量删除当前路径下的指定工作簿的过程和创建的过程几乎一致，只不过一个是"Workbooks.Add 工作簿"的过程，一个是"Kill 工作簿"的过程，这里用一个示例中的两段代码来演示。

如图所示，按照工作表的名单，在当前工作簿中批量创建(删除)工作表：

运行视频：

源码下载：

描述：

根据指定名单在当前路径下批量创建或删除工作簿

VBA实现过程：

1.ThisWorkbook.Path，当前工作簿所在的路径；
2.Set newWb = Workbooks.Add，创建一个工作簿；
3.newWb.SaveAs Filename:=，保存工作簿，后跟一个完整路径 + 工作簿名称 + 后缀；
4.newWb.Close SaveChanges:=False，不保存关闭；
5.Dir(file_path_name)，Dir函数，检查特定文件是否存在，参数是一个完整的文件路径，包含路径和文件名称和后缀，比如Dir(C:\文件夹1\文件1.txt)，检查“C:\文件夹1\”路径下的“文件1.txt”是否存在，如果存在该文件，则返回文件名称“文件1.txt”，不存在则返回空。

示例代码（批量创建）

复制成功!


Sub 工作表名单批量创建工作簿()

    Dim Name_list, rng As Range
    Dim Str_name As String
    Dim file_path As String
    Dim newWb As Workbook

    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 '选择的单元格区域内容都是空时也退出

    ' 禁用屏幕更新和警告
    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"   '保存工作簿在当前路径下，名字用名单的名字
            newWb.Close SaveChanges:=False              '不保存关闭新工作簿

        End If
    Next rng

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

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

End Sub

示例代码（批量删除）

复制成功!


Sub 工作表名单批量删除工作簿()
    Dim Name_list, rng As Range
    Dim Str_name As String
    Dim file_path, file_path_name As String
    Dim newWb As Workbook

    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 '选择的单元格区域内容都是空时也退出


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

    For Each rng In Name_list                           '遍历名单
        Str_name = rng.Value                            '单元格内容赋值作为工作表名称
        If Len(Str_name) Then                           '如果名称非空
            Err.Clear
            file_path_name = file_path & Str_name & ".xlsx"

            If Dir(file_path_name) <> "" Then         '检查文件是否存在，如果存在就删除
                Kill file_path_name
            End If

        End If
    Next rng

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

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

End Sub