VBA 指定された年月の日付シート作成

' 指定された年月の日付シートを作成する
'「main」シートのセル【C5】に年、セル【D5】に月をもとに
'その月の日付のシートを作成
'ユーザ誤って削除した日がある場合は、その日だけのシートを作成
' 作成したシートのセル【A3】に日付(yyyy/m/d)を入力する
' 並び順は「同月の既存シートの隣」に挿入して保つ

Public Sub CreateSheetsForMonth()
    Const WS_DEF As String = "DEF"
    Const WS_MAIN As String = "main"
    
    Dim wsMain As Worksheet
    Dim wsBase As Worksheet
    
    Dim yearVal As Long
    Dim monthVal As Long
    Dim lastDay As Long
    Dim d As Long
    
    Dim currentDate As Date
    Dim sheetName As String
    Dim wasHidden As Boolean
    
    Dim idxBefore As Long
    Dim idxAfter As Long
    
    On Error GoTo EH
    Dim wb As Workbook
    Set wb = ThisWorkbook
    With wb
        Set wsMain = .Worksheets(WS_MAIN)
        Set wsBase = .Worksheets(WS_DEF)
    End With
    
    ' === 年月の取得 ===
    Dim yVal As Variant, mVal As Variant
    With wsMain
        yVal = .Range("C5").Value
        mVal = .Range("D5").Value
    End With
    
    If Not (IsNumeric(yVal) And IsNumeric(mVal)) Then
        MsgBox "年または月の入力が数値ではありません。", vbExclamation
        Exit Sub
    End If
    
    yearVal = CLng(yVal)
    monthVal = CLng(mVal)

    If monthVal < 1 Or monthVal > 12 Or yearVal < 1900 Then
        MsgBox "年または月の入力が不正です。", vbExclamation
        Exit Sub
    End If
    
    lastDay = Day(DateSerial(yearVal, monthVal + 1, 0))
    
    ' === コピー元が非表示なら一時的に表示 ===
    wasHidden = (wsBase.Visible <> xlSheetVisible)
    If wasHidden Then wsBase.Visible = xlSheetVisible
    
    Application.ScreenUpdating = False
    
    ' === シート作成＆正しい位置へ挿入 ===
    For d = 1 To lastDay
        currentDate = DateSerial(yearVal, monthVal, d)
        sheetName = BuildDateSheetName(currentDate)
        
        If Not SheetExists(sheetName) Then
            ' 直前・直後の既存日付シート（同じ月）を探索
            FindNeighborIndices yearVal, monthVal, d, idxBefore, idxAfter
            
            If idxBefore > 0 Then
                wsBase.Copy After:=wb.Worksheets(idxBefore)
            ElseIf idxAfter > 0 Then
                wsBase.Copy Before:=wb.Worksheets(idxAfter)
            Else
                ' 同月のシートが1枚も無い場合は末尾へ
                wsBase.Copy After:=wb.Worksheets(wb.Worksheets.Count)
            End If
            
            With wb.ActiveSheet
                .Name = sheetName
                .Range("A3").Value = Format$(currentDate, "yyyy/m/d")
            End With
        End If
    Next d
    
    
    ' === 元の可視状態に戻す ===
    If wasHidden Then wsBase.Visible = xlSheetHidden
    
    Application.ScreenUpdating = True
    
    wsMain.Activate
    MsgBox "シート作成が完了しました。", vbInformation
    Exit Sub

EH:
    If wasHidden Then wsBase.Visible = xlSheetHidden
    MsgBox "エラー: " & Err.Description, vbExclamation
    Application.ScreenUpdating = True
End Sub

'=======================
' 補助関数
'=======================

Private Function SheetExists(ByVal sheetName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets(sheetName)
    SheetExists = Not (ws Is Nothing)
    Set ws = Nothing
    On Error GoTo 0
End Function

' シート名を "mm_dd(aaa)" で構成
Private Function BuildDateSheetName(ByVal theDate As Date) As String
    BuildDateSheetName = Format$(theDate, "m_d") & "(" & Format$(theDate, "aaa") & ")"
End Function

' シート名が "mm_dd(...)" 形式かつ、指定の年月と一致するかを判定し、日を返す
Private Function ParseTargetMonthDay(ByVal sheetName As String, _
                                     ByVal yearVal As Long, _
                                     ByVal monthVal As Long, _
                                     ByRef dayOut As Long) As Boolean
    Dim mmPart As String
    Dim ddPart As String
    Dim mmVal As Long
    Dim ddVal As Long
    
    ' 形式チェック："##_##(*)"
    If Not sheetName Like "##_##(*)" Then
        ParseTargetMonthDay = False
        Exit Function
    End If
    
    mmPart = Left$(sheetName, 2)
    ddPart = Mid$(sheetName, 4, 2)
    
    If Not IsNumeric(mmPart) Or Not IsNumeric(ddPart) Then
        ParseTargetMonthDay = False
        Exit Function
    End If
    
    mmVal = CLng(mmPart)
    ddVal = CLng(ddPart)
    
    If mmVal = monthVal Then
        dayOut = ddVal
        ParseTargetMonthDay = True
    Else
        ParseTargetMonthDay = False
    End If
End Function

' 同じ年月で「ターゲット日 d」の直前(最も大きい<d)と直後(最も小さい>d)の
' 既存シートのインデックスを返す。なければ 0。
Private Sub FindNeighborIndices(ByVal yearVal As Long, _
                                ByVal monthVal As Long, _
                                ByVal d As Long, _
                                ByRef idxBefore As Long, _
                                ByRef idxAfter As Long)
    Dim i As Long
    Dim ws As Worksheet
    Dim dayFound As Long
    Dim bestBeforeDay As Long
    Dim bestAfterDay As Long
    
    idxBefore = 0
    idxAfter = 0
    bestBeforeDay = -1          ' 最大の(<d)
    bestAfterDay = 9999         ' 最小の(>d)
    
    For i = 1 To ThisWorkbook.Worksheets.Count
        Set ws = ThisWorkbook.Worksheets(i)
        If ParseTargetMonthDay(ws.Name, yearVal, monthVal, dayFound) Then
            If dayFound < d Then
                If dayFound > bestBeforeDay Then
                    bestBeforeDay = dayFound
                    idxBefore = i
                End If
            ElseIf dayFound > d Then
                If dayFound < bestAfterDay Then
                    bestAfterDay = dayFound
                    idxAfter = i
                End If
            End If
        End If
    Next i
End Sub

コメント