VBA 一键批量创建工作簿、工作表

学会VBA，工作好轻松

1. 一键批量创建工作簿

在活动的Excel文件，表A列里面批量填写需要创建工作簿的名称，把如下短短10来行VBA代码复制到编辑器模块下运行，相关文件即刻被创建

Private Sub CommandButton1_Click()
 '动态根据A列的有效内容创建工作簿
        Dim NewBook As Workbook
        Dim LastCell As Range
        Set LastCell = Range("a" & Rows.Count).End(xlUp)
        Dim rng As Range
        For Each rng In Sheets(1).Range("a2", LastCell)
            Set NewBook = Workbooks.Add '新建工作簿
            NewBook.SaveAs (ThisWorkbook.Path & "\" & rng.Value & ".xlsx") '保存工作簿
            NewBook.Close  '关闭工作簿
        Next rng
End Sub

2.一键批量创建工作表

Sub 批量创建工作表()
    ' 动态根据A列的有效内容批量创建工作表
    ' 表名为A列列名
        Dim rng As Range, Wb As Workbook, WS As Worksheet
        Dim LastCell As Range
        Set LastCell = Range("a" & Rows.Count).End(xlUp)
        Set Wb = Workbooks.Add
        For Each rng In Sheet1.Range("a2", LastCell)
            Set WS = Wb.Sheets.Add
            WS.name = rng.Value
        Next rng
        Application.DisplayAlerts = False
        Wb.Sheets(Wb.Sheets.Count).Delete
        Application.DisplayAlerts = True
        Wb.SaveAs (ThisWorkbook.Path & "\" & Sheet1.Cells(1, 1).Value & ".xlsx")
        Wb.Close
        MsgBox ("批量创建工作表完毕！")
End Sub

3、一键批量创建工作表进阶

在批量创建工作表的同时，把模板工作表复制到新创建的工作表

Sub 批量创建工作表进阶2()
    ' 动态根据A列的有效内容批量创建工作表
    ' 表名为A列列名
    ' 将sheet2作为模板源批量复制到新创建的表中
        Dim rng As Range, Wb As Workbook, WS As Worksheet
        Dim LastCell As Range
        Dim lastRow As Long, lastColumn As Long
        lastRow = Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Row
        lastColumn = Sheet2.Cells(5, Sheet2.Columns.Count).End(xlToLeft).Column
        Set LastCell = Sheet1.Range("a" & Rows.Count).End(xlUp)
        Set Wb = Workbooks.Add
        For Each rng In Sheet1.Range("a2", LastCell)
            Set WS = Wb.Sheets.Add
            WS.name = rng.Value
            Sheet2.Range("A1", Sheet2.Cells(lastRow, lastColumn)).Copy WS.Range("a1")
        Next rng
        Application.DisplayAlerts = False
        Wb.Sheets(Wb.Sheets.Count).Delete
        Application.DisplayAlerts = True
        Wb.SaveAs (ThisWorkbook.Path & "\" & Sheet1.Cells(1, 1).Value & ".xlsx")
        Wb.Close
        msgbox("模板化批量创建工作表完毕！")
End Sub