从 InputBox 获取日期

喜欢这个：

Sub NewMonth_button()

    Dim Date_Today As Date
    Dim Date_Text  As String
    Dim nwFilename As String

    Date_Text = InputBox("Please enter YEAR-Month")
    If IsDate(Date_Text & "-01") Then
        Date_Today = DateValue(Date_Text & "-01")
        nwFilename = "Daily Journal_" & Format(Date_Today, "yyyy_mm")

        Worksheets(Array("list", "data", "Fill", "Archive>")).Copy
        ActiveWorkbook.SaveAs filename:=ThisWorkbook.Path & Application.PathSeparator & nwFilename
    End If

End Sub

创建每月工作簿

Sub CreateMonthlyWorkbook()
     
    ' Define constants.
    Const PROC_TITLE As String = "Create Monthly Workbook"
    Const DST_FILE_NAME_LEFT As String = "Daily Journal_"
    ' The following two need to be in sync:
    Const DST_FILE_EXTENSION As String = ".xlsx"
    Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
    Dim dSheetNames() As Variant:
    dSheetNames = Array("list", "data", "Fill", "Archive>")
    Const PERIOD_DELIMITER As String = "-" ' single character!
    Const PERIOD_FILE_DELIMITER As String = "_"
    Const PERIOD_YEAR_FORMAT As String = "yyyy" ' fixed!
    Const PERIOD_MONTH_FORMAT As String = "m" ' or 'mm' fixed!
    Const YEAR_MIN As Long = 2001 ' Excel Min = 1900
    Const YEAR_MAX As Long = 2030 ' Excel Max = 9999
    Const MONTH_MIN As Long = 1
    Const MONTH_MAX As Long = 12
    
    ' Reference the source workbook.
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    
    ' Determine the destination folder path.
    Dim dFolderPath As String: dFolderPath = swb.Path
    
    ' Determine the input parameters.
    Dim PeriodFormat As String: PeriodFormat = PERIOD_YEAR_FORMAT _
        & PERIOD_DELIMITER & PERIOD_MONTH_FORMAT
    Dim iPrompt As String: iPrompt = "Please enter the period in """ _
        & PeriodFormat & """ format:"
    Dim iDefault As String: iDefault = Format(Date, PeriodFormat) ' current
       
    ' Input.
       
    Application.ScreenUpdating = False
       
    Dim PeriodInput As Variant, PerLen As Long, DelPos As Long
    Dim YearValue As Variant, MonthValue As Variant, IsPeriodValid As Boolean
    
    Do
        ' Input.
        PeriodInput = Application _
            .InputBox(iPrompt, PROC_TITLE, iDefault, , , , , 2) ' 2 - string
        ' Canceled.
        If VarType(PeriodInput) = vbBoolean Then
            MsgBox "Canceled. Workbook not created.", _
                vbExclamation, PROC_TITLE
            Exit Sub
        End If
        ' Not canceled.
        PerLen = Len(PeriodInput)
        If PerLen = 6 Or PerLen = 7 Then
            DelPos = InStr(PeriodInput, PERIOD_DELIMITER)
            If DelPos = 5 Then
                YearValue = Left(PeriodInput, 4)
                If YearValue Like "####" Then
                    YearValue = CLng(YearValue)
                    If YearValue >= YEAR_MIN And YearValue <= YEAR_MAX Then
                        MonthValue = Right(PeriodInput, PerLen - DelPos)
                        If MonthValue Like "#" Or MonthValue Like "##" Then
                            MonthValue = CLng(MonthValue)
                            If MonthValue >= MONTH_MIN _
                                    And MonthValue <= MONTH_MAX Then
                                IsPeriodValid = True
                            End If
                        End If
                    End If
                End If
            End If
        End If
    Loop Until IsPeriodValid = True
    
    ' Build the destination file path.
    
    Dim DateString As String: DateString = YearValue & PERIOD_FILE_DELIMITER _
        & Format(MonthValue, String(Len(PERIOD_MONTH_FORMAT) - 1, "0") & "#")
    Dim dFileName As String:
    dFileName = DST_FILE_NAME_LEFT & DateString & DST_FILE_EXTENSION
    Dim dFilePath As String:
    dFilePath = dFolderPath & Application.PathSeparator & dFileName
    
    If Len(Dir(dFilePath)) > 0 Then
        MsgBox "The file """ & dFileName & """ already exists in folder """ _
            & dFolderPath & """!", vbCritical, PROC_TITLE
        Exit Sub
    End If
    
    ' Copy the sheets to a new workbook.
    swb.Sheets(dSheetNames).Copy
    
    ' Save (and close) the newly created workbook.
    With Workbooks(Workbooks.Count)
        .SaveAs Filename:=dFilePath, FileFormat:=dFileFormat
        '.Close SaveChanges:=False
    End With

    Application.ScreenUpdating = True

    ' Inform.
    MsgBox "Created workbook """ & dFileName & """ in folder """ _
            & dFolderPath & """.", vbInformation, PROC_TITLE

End Sub