投稿/コメントを表示します。

発展編1 フォローメールセミナー
発展編1 フォローメールセミナー　第29回

受講生さんの投稿

(投稿ID: 5010)

お世話になっております。
空でカレンダーマクロを１から作りましたので添削して頂けると嬉しいです。
コメント部分に自身なりの考えでアレンジした部分を示しています。
よろしくお願いします。(｀・ω・´)
Option Explicit
Dim c, saKi, saiGo, yoKo, Gyo As Long '変数をカテゴリー別にまとめた
Dim Hiduke, hiNiti As Date
Dim Sum, Ctrl, ws As Worksheet
Dim SumrA, CtrlA1, CtrlF2 As Range
Dim Syuku As Boolean
'これくらいのものであれば、シート作成とカレンダ―内の作業の
'プロシージャを分けなくてもそこまでややこしくないと考え、一緒にした。
Sub Carenda_soukatu()
    Sheet_sakujo
    Hiduke = #1/1/2021#
    Set Sum = Worksheets("Summary")
    Set Ctrl = Worksheets("Control")
    Set CtrlA1 = Ctrl.Range("A1")
    For c = 1 To 12
        Sum.Copy after:=Sheets(Sheets.Count)
        ActiveSheet.Name = c & "月"
    Next
    For c = 1 To 12
        Worksheets(c & "月").Activate
        saiGo = Sum.Range("A" & Sum.Rows.Count).End(xlUp).Row + 1
        Carenda_main
        Hiduke = DateAdd("m", 1, Hiduke)
    Next
    Ctrl.Activate
End Sub
Sub Carenda_main()
    hiNiti = Hiduke
    saKi = 0
    With Range("A2")
        Do While Month(hiNiti) = Month(Hiduke)
            .Offset(saKi).Value = hiNiti
            .Offset(saKi, 1).Value = WeekdayName(Weekday(hiNiti))
            .Offset(saKi, 2).Value = #9:00:00 AM#
            .Offset(saKi, 3).Value = #5:00:00 PM#
            .Offset(saKi, 4).Formula = "=" & .Offset(saKi, 3).Address & "-" & .Offset(saKi, 2).Address
            Set SumrA = Sum.Range("A" & saiGo)
            For yoKo = 0 To 4
                SumrA.Offset(saKi, yoKo).Formula = "=" & .Worksheet.Name & "!" & .Offset(saKi, yoKo).Address
            Next
            
            Syuku_hantei
            Set CtrlF2 = Ctrl.Range("F2") '４回も出てきて煩わしいので１つの変数として置いた
            If Syuku = True Then
                With Range(.Offset(saKi), .Offset(saKi, 4))
                    .Interior.Color = CtrlF2.Interior.Color
                    .Font.Color = CtrlF2.Font.Color
                End With
                With Range(SumrA.Offset(saKi), SumrA.Offset(saKi, 4))
                    .Interior.Color = CtrlF2.Interior.Color
                    .Font.Color = CtrlF2.Font.Color
                End With
            Else
                With Range(.Offset(saKi), .Offset(saKi, 4))
                    .Interior.Color = CtrlA1.Offset(Weekday(hiNiti)).Interior.Color
                    .Font.Color = CtrlA1.Offset(Weekday(hiNiti)).Font.Color
                End With
                With Range(SumrA.Offset(saKi), SumrA.Offset(saKi, 4))
                    .Interior.Color = CtrlA1.Offset(Weekday(hiNiti)).Interior.Color
                    .Font.Color = CtrlA1.Offset(Weekday(hiNiti)).Font.Color
                End With
            End If
            
            hiNiti = DateAdd("d", 1, hiNiti)
            saKi = saKi + 1
        Loop
    End With
End Sub
Sub Syuku_hantei()
    Syuku = False
    For Gyo = 2 To 18
'あくまで今年のカレンダーを作ったため↓。
        If Month(hiNiti) = Month(Ctrl.Range("C" & Gyo).Value) And _
           Day(hiNiti) = Day(Ctrl.Range("C" & Gyo).Value) Then
            Syuku = True
            Exit For
        End If
    Next
End Sub
Sub Sheet_sakujo()
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If ws.Name <> "Control" And ws.Name <> "Summary" Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
    Sum_clear
End Sub
Sub Sum_clear()
    Set Sum = Worksheets("Summary")
    saiGo = Sum.Range("A" & Sum.Rows.Count).End(xlUp).Row
    If saiGo > 1 Then
        With Sum.Range("A2:E" & saiGo)
            .ClearContents
            .Interior.Color = xlNone
            .Font.Color = vbBlack
        End With
    End If
End Sub

2021/02/20 19:50