這期給大家分享下如何按指定名單和模板批量創(chuàng)建工作簿。
如上圖所示，有一張工作表提供了新建工作簿的名單，又有一個(gè)工作表名為”模板”，作為新建工作簿的模板。則運(yùn)行以下代碼即可按指定名單和模板批量創(chuàng)建工作簿。
Sub NewWbByTemp()
Dim rngData As Range, c As Range
Dim strName As String, strPath As String
Dim n As Long, y As Long, strErr As String
Dim shtTemp As Worksheet
On Error Resume Next '忽略程序錯(cuò)誤繼續(xù)運(yùn)行
Set rngData = getRngData() '用戶(hù)選擇名單區(qū)域
If Err.Number Then Exit Sub '如果選擇無(wú)效區(qū)域則退出程序
Set shtTemp = Worksheets("模板")
If Err.Number Then
MsgBox "HI，沒(méi)找到名為模板的工作簿，請(qǐng)核實(shí)。"
Exit Sub
End If
Call disAppSet '取消屏幕刷新等系統(tǒng)設(shè)置
strPath = ThisWorkbook.Path '當(dāng)前工作簿的路徑為新建工作簿保存路徑
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
For Each c In rngData '遍歷名單
strName = c.Value '工作簿名稱(chēng)
If Len(strName) Then '如果工作簿名稱(chēng)非空
Err.Clear '清除錯(cuò)誤
shtTemp.Copy '復(fù)制工作表，不指定位置參數(shù)，會(huì)成為活動(dòng)工作簿
ActiveWorkbook.SaveAs strPath & strName '保存工作簿
If Err.Number Then '如果存在錯(cuò)誤，說(shuō)明工作簿名稱(chēng)不規(guī)范
n = n + 1 '記錄問(wèn)題名稱(chēng)數(shù)量
strErr = strErr & "," & strName '記錄名稱(chēng)
Else
y = y + 1 '記錄正確創(chuàng)建工作簿的數(shù)量
End If
ActiveWorkbook.Close , False
End If
Next
Call reAppSet
If n Then
MsgBox "有" & n & "張工作簿創(chuàng)建失敗，原因是工作簿重名或格式錯(cuò)誤。" & _
"名單如下：" & vbCrLf & _
Mid(strErr, 2)
ElseIf y Then
MsgBox "創(chuàng)建完成。"
End If
End Sub
Sub disAppSet()
With Application '取消屏幕刷新、信息警告、公式重算等
.ScreenUpdating = False
.DisplayAlerts = False
.AskToUpdateLinks = False
.Calculation = xlCalculationManual
End With
End Sub
Sub reAppSet()
With Application '取消屏幕刷新、信息警告、公式重算等
.ScreenUpdating = True
.DisplayAlerts = True
.AskToUpdateLinks = True
.Calculation = xlCalculationAutomatic
End With
End Sub
'用戶(hù)選擇名稱(chēng)來(lái)源區(qū)域
Function getRngData() As Range
Dim rngData As Range
Set rngData = Application.InputBox("請(qǐng)選擇新建工作簿名稱(chēng)來(lái)源。", _
Title:="提示", _
Default:=Selection.Address, _
Type:=8) '用戶(hù)選擇名稱(chēng)來(lái)源區(qū)域
Set rngData = Intersect(rngData, rngData.Parent.UsedRange)
'交集運(yùn)算，避免用戶(hù)選擇整列數(shù)據(jù)造成運(yùn)算量虛大或選擇區(qū)域空白
If rngData Is Nothing Then '如果用戶(hù)關(guān)閉了對(duì)話(huà)框，或選擇區(qū)域空白，則退出程序
MsgBox "未選擇有效區(qū)域。"
Exit Function
End If
Set getRngData = rngData
End Function
代碼詳細(xì)解釋見(jiàn)注釋……
打個(gè)響指，坦白的說(shuō)，這段代碼和上一期代碼十分相似，簡(jiǎn)直是同父異母的哥倆好。第9行至第13行代碼，指定名稱(chēng)為”模板”的工作表為新建工作簿的模板；如果當(dāng)前工作簿查無(wú)此表，則退出程序。
第21行代碼使用工作表的Copy方法復(fù)制一個(gè)工作表，但未指定復(fù)制后工作表的保存位置；我們上一章講過(guò)，這種情況下，系統(tǒng)會(huì)將該工作表轉(zhuǎn)換為活動(dòng)工作簿。
第22行代碼將活動(dòng)工作簿保存到指定路徑下。第23至28行代碼判斷工作簿名稱(chēng)是否符合規(guī)則。其余代碼和上一節(jié)代碼并無(wú)二樣，也就不需贅言。
承擔(dān)因您的行為而導(dǎo)致的法律責(zé)任，
本站有權(quán)保留或刪除有爭(zhēng)議評(píng)論。
參與本評(píng)論即表明您已經(jīng)閱讀并接受
上述條款。