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

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

受講生さんの投稿

(投稿ID: 4750)

お世話になります。
今回のセミナーまでのカレンダー作成を何も見ずに１から書き上げてみました。
サンプルコードと違う部分記述やまとめ方をしている部分もいくつかありますので添削していただけると幸いです。
Option Explicit

Dim dt1 As Date
Dim b As Boolean
Sub shCreate()
    
    Dim lnMon As Long
    Dim shTo As Worksheet
    Dim lnMx As Long
    
    Application.ScreenUpdating = False
    lnMx = Worksheets("Summary").Range("A" & Worksheets("Summary").Rows.Count).End(xlUp).Row
    
    Dim dt As Date
    dt = #1/1/2009#
    
    If lnMx > 1 Then
        Worksheets("Summary").Range("A2", "E" & lnMx).ClearContents
        Worksheets("Summary").Range("A2", "E" & lnMx).Interior.Pattern = xlNone
        Worksheets("Summary").Range("A2", "E" & lnMx).Font.ColorIndex = 1
        Worksheets("Summary").Range("A2", "E" & lnMx).Font.Bold = False
    End If
    
    shDelete
    For lnMon = 1 To 12
        Sheets("Summary").Copy After:=Sheets(Worksheets.Count)
        Set shTo = ActiveSheet
        shTo.Name = lnMon & "月"
    Next
    
    Dim c As Long
    c = 1
    Dim ws As Worksheet
    For Each ws In Worksheets
        If Right(ws.Name, 1) = "月" Then
            ws.Select
            dt1 = DateAdd("m", c - 1, dt)
            shKousei
            c = c + 1
        End If
    Next
    Worksheets("Summary").Select
    Application.ScreenUpdating = True
End Sub

Sub shDelete()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If Not ws Is Worksheets("Control") Then
            If Not ws Is Worksheets("Summary") Then
                ws.Delete
            End If
        End If
    Next
    Application.DisplayAlerts = True
End Sub

Sub shKousei()
    Dim dt2 As Date
    Dim c As Long
    Dim n As Long
    Dim shSummary
    Set shSummary = Worksheets("Summary")
    Dim shControl
    Set shControl = Worksheets("control")
    Dim lnSumMx
    
    lnSumMx = shSummary.Range("A" & shSummary.Rows.Count).End(xlUp).Row - 1
    
    dt2 = dt1
    c = 0
    
    Dim rgSummary As Range
    Dim rgControl As Range
    
    With Range("A2")
        Do While Month(dt1) = Month(dt2)
            .Offset(c, 0).Value = dt1
            .Offset(c, 1).Value = WeekdayName(Weekday(dt1))
            .Offset(c, 2).Value = #9:00:00 AM#
            .Offset(c, 3).Value = #5:00:00 PM#
            .Offset(c, 4).Formula = "=" & .Offset(c, 3).Address & "-" & .Offset(c, 2).Address
            Holiday
            For n = 0 To 4
                Set rgSummary = shSummary.Range("A2").Offset(lnSumMx + c, n)
                Set rgControl = shControl.Range("A1").Offset(Weekday(dt1), 0)
                rgSummary.Formula = "='" & .Worksheet.Name & "'!" & .Offset(c, n).Address
                With .Offset(c, n)
                    If b = True Then
                        .Interior.ColorIndex = shControl.Range("F2").Interior.ColorIndex
                        .Font.ColorIndex = shControl.Range("F2").Font.ColorIndex
                        .Font.Bold = shControl.Range("F2").Font.Bold
                        rgSummary.Interior.ColorIndex = shControl.Range("F2").Interior.ColorIndex
                        rgSummary.Font.ColorIndex = shControl.Range("F2").Font.ColorIndex
                        rgSummary.Font.Bold = shControl.Range("F2").Font.Bold
                    Else
                        .Interior.ColorIndex = rgControl.Interior.ColorIndex
                        .Font.ColorIndex = rgControl.Font.ColorIndex
                        rgSummary.Interior.ColorIndex = rgControl.Interior.ColorIndex
                        rgSummary.Font.ColorIndex = rgControl.Font.ColorIndex
                    End If
                End With
            Next
            dt1 = DateAdd("d", 1, dt1)
            c = c + 1
        Loop
    End With
End Sub

Sub Holiday()
    b = False
    Dim c As Long
    For c = 2 To 18
        If dt1 = Worksheets("Control").Range("C" & c).Value Then
            b = True
        End If
    Next
End Sub

2020/06/01 03:47