Sub MonthlySht()
    Dim MyToday As Date
    Dim InputMonth As String
    Dim OldNewBookSheetsCount As Long
    Dim MyData(1, 1) As Variant
    Dim PvtItem As PivotItem
    Dim MySht As Worksheet
    Dim TargetMonth As String

    MyToday = Date
    With Application
        Do
            InputMonth = .InputBox(Prompt:="作成する月を半角で入力してね！", _
            Title:="マンスリーシートの作成", _
            Default:=Month(MyToday), Type:=2)
            If InputMonth = "False" Then Exit Sub
            InputMonth = Val(InputMonth)
        Loop Until InputMonth >= 1 And InputMonth <= 12
        .ScreenUpdating = False
        OldNewBookSheetsCount = .SheetsInNewWorkbook
        .SheetsInNewWorkbook = 1
        .Workbooks.Add
        .SheetsInNewWorkbook = OldNewBookSheetsCount
    End With
    With ActiveWorkbook
        With .Worksheets(1)
            MyData(0, 0) = "日付"
            MyData(0, 1) = "値"
            MyData(1, 0) = MyToday
            MyData(1, 1) = 1
            .Range("A1:B2").Value = MyData
            .PivotTableWizard SourceType:=xlDatabase, _
                SourceData:=.Range("A1").CurrentRegion.Address(External:=True), _
                TableDestination:=.Range("A6"), HasAutoFormat:=False
            With .PivotTables(1)
                .PreserveFormatting = False
                .AddFields RowFields:="日付"
                .PivotFields("値").Orientation = xlDataField
                .RowRange.Range("A1").Group Start:=True, End:=True, _
                    Periods:=Array(False, False, False, True, False, False, False)
                With .PivotFields("日付")
                    .Orientation = xlPageField
                    If InputMonth = "2" Then
                        If IsDate(Year(MyToday) & "/2/29") = False Then
                            .PivotItems("2月29日").Visible = False
                        End If
                    End If
                    TargetMonth = InputMonth & "月*"
                    For Each PvtItem In .PivotItems
                        If Not PvtItem.Caption Like TargetMonth Then
                            PvtItem.Visible = False
                        End If
                    Next PvtItem
                End With
                .ShowPages PageField:="日付"
            End With
        End With
        For Each MySht In .Worksheets
            MySht.Range("A:B").Clear
        Next
        Application.DisplayAlerts = False
        .Sheets(Sheets.Count).Delete
        Application.DisplayAlerts = True
    End With
    Application.ScreenUpdating = True
End Sub