VBA系列-020.按指定名称批量创建工作簿

Sub CreateFiles()
    Dim strPath As String, strFileName As String
    Dim i As Long, r
    On Error Resume Next
    With Application.FileDialog(msoFileDialogFolderPicker)
        '用户选择文件夹路径
        If .Show Then strPath = .SelectedItems(1) Else Exit Sub
        '如果用户为选择文件夹则退出程序
    End With
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    Application.ScreenUpdating = False '取消屏幕刷新
    Application.DisplayAlerts = False '取消警告提示,当有重名工作簿时直接覆盖
    r = Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row) '数据装入数组r
    For i = 2 To UBound(r) '标题不要,因此从第2个元素开始遍历数组r
        With Workbooks.Add '新建工作簿
            .SaveAs strPath & r(i, 1), xlWorkbookDefault
            '以指定名称、默认文件类型保存工作簿
            .Close True '关闭工作簿
        End With
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "创建完成。"
End Sub