VBA：新檔案名及將本頁另存新檔

　
　
Sub jj()
'
' 2009/11/14
'
' 分為兩部份
' 1- 制作新檔案名，HD-yyyymmdd
' 2- 只將本頁另存新檔

' **************************************************************************
' *********** 第 1 部份 制作新檔案名，HD-yyyymmdd
' *********** XP 的時間系統亦要改為 yyyy / mm / dd 格式
' **************************************************************************
Dim Message, Title, Default, MyValue
Message = "請輸入更紙日期 ( DD / MM / YYYY ) " ' 設定提示訊息。
Title = "另存各 PIT 即日更紙" ' 設定標題。

aYear = Right("00" & Year(Now()), 4)
aMonth = Right("0" & Month(Now()), 2)
aDay = Right("0" & Day(Now()), 2)


Default = aDay & "/" & aMonth & "/" & aYear ' 設定預設值。
' 顯示訊息、標題及預設值。
MyValue = InputBox(Message, Title, Default)

If IsDate(MyValue) Then
aYear = Right("00" & Year(MyValue), 4)
aMonth = Right("0" & Month(MyValue), 2)
aDay = Right("0" & Day(MyValue), 2)
myfilename = "HR-" & aYear & aMonth & aDay
MsgBox myfilename
Else
MsgBox "錯日期"
Exit Sub
End If

' **************************************************************************
' *********** 第 2 部份 將本頁另存新檔
' **************************************************************************

NewFilePath = "c:"

ActiveSheet.Name = myfilename
ActiveWorkbook.SaveAs Filename:=NewFilePath & "\" & myfilename

For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> myfilename Then
Application.DisplayAlerts = False
Ws.Delete
End If
Next Ws
ActiveWorkbook.Save
End Sub