EXCEL VBA创建sheet/工作簿

1.需要创建以地市命名的系列sheet，但不想手动创建改名。

代码实现如下：

    Sub SheetAdd()
    
    Dim i As Long
    
    '定义一个长整型变量
    
    Sheets.Add After:=Sheets(Sheets.Count), Count:=Sheets(1).Range("A" & Rows.Count).End(xlUp).Row - 1
    
    '在现有Sheet后新建工作表，工作表数量等于Sheet(1)表A列非空单元格行数
    
    For i = 2 To Sheets.Count
    
    Sheets(i).Name = Sheets(1).Cells(i, 1).Value
    
    '工作表名称设置为Sheet(1)A列单元格值
    
    Next
    
    MsgBox "创建工作表完成！"
    
    End Sub

完成后如图：

2.那么，创建完成后需要把系列sheet分离成独立的工作簿该如何呢，

VBA实现代码如下：

    Sub 拆分工作簿()
    
    Dim sht As Worksheet '定义一个工作表变量 sht
    
    Dim mybook As Workbook '定义一个工作簿变量 mybook
    
    Application.ScreenUpdating = False '关闭屏幕更新:作用为加快宏的执行速度,这样将看不到宏的执行过程，但宏的执行速度加快了。
    
    Set mybook = ActiveWorkbook '将当前工作簿赋值给变量 mybook
    
    For Each sht In mybook.Sheets ' FOR 循环实现将工作簿中的多个工作表拆开成以工作表名称命名的工作簿并保存在原工作簿相同的路径中
    
    sht.Copy
    
    ActiveWorkbook.SaveAs Filename:=mybook.Path & "\" & sht.Name, FileFormat:=xlNormal
    
    ActiveWorkbook.Close
    
    Next
    
    Application.ScreenUpdating = True '恢复屏幕刷新 ，屏幕刷新 False /True 需成对出现 。
    
    MsgBox "工作簿已经拆分完毕"
    
    End Sub

完成如图：

3.以上两个步骤可以归纳为：按指定名称批量创建Excel工作簿。

VBA代码实现如下：

    Sub Createwks()
    
        Dim i&, p$, r
    
        Application.ScreenUpdating = False
    
        '取消屏幕刷新
    
        Application.DisplayAlerts = False
    
        '取消警告提示，当有重名工作簿时直接覆盖
    
        p = ThisWorkbook.Path & "\"
    
        '当前工作簿所在的路径
    
        r = [a1].CurrentRegion '数据装入数组r
    
        For i = 2 To UBound(r)
    
        '标题不要，因此从第2个元素开始遍历数组r
    
            With Workbooks.Add '新建工作簿
    
                .SaveAs p & r(i, 1), xlWorkbookDefault
    
                '保存工作簿
    
                .Close True
    
                '关闭工作簿
    
            End With
    
        Next
    
        Application.ScreenUpdating = True
    
        Application.DisplayAlerts = True
        MsgBox "工作簿已经创建完毕"
    
    End Sub

完成后如图：