Function Create_New_Workbook() '新建工作薄
Application.ScreenUpdating = False
Dim gzb As Workbook
Dim mypath, i, wb
mypath = ThisWorkbook.Path '獲取當前工作薄所在的路徑
Set wb = GetObject(mypath & "\" & "date.xls") '設置wb爲當前目錄下的date.xls工作薄
i = 1
Do While Cells(i, 1) <> ""
Set gzb = Workbooks.Add
gzb.SaveAs mypath & "\" & wb.Worksheets(1).Cells(i, 1).Text & ".xls" '保存工作薄的名字爲Cells(i,1)中的字符
gzb.Close
i = i + 1
Loop
Application.ScreenUpdating = True
End Function