【EXCEL VBA】週数を指定した曜日を取得、月毎の日を取得

「GetTargetDay.zip」をダウンロード

月単位で第Ｘ週の月～金曜日、毎月Ｘ日といった指定をすることで、指定の曜日を取得させるマクロ。

定例作業の予定作成時に必要な日時を抽出するために作成。

こういった「ある日」を見分ける感覚は、スケジュール帳やカレンダーを見ながら、自分の頭で考えることも大切だけど、やはり面倒くさいので。。

Option Explicit

Sub Exec()

    Dim start As Date
    Dim i As Date
    Dim limit As Date
    Dim r As Range
    Set r = Range("J4")
   
    Range("J:J").ClearContents
   
    start = Range("A4")
    limit = Range("B4")
   
    For i = start To limit
        If IsWrite(i) = True Then
            r.Value = i
           Set r = r.Offset(1, 0)
        End If
    Next i
   
   
End Sub

Function IsWrite(d) As Boolean
    IsWrite = False
   
    Dim weeks As Integer
   
    ‘祝日は対象外
    Dim r As Range
    For Each r In Range("C4:C40")
        If r.Value = d Then
            GoTo FINALLY:
        End If
    Next r
       
    ‘第Ｘ　Ｙ曜日？
    For Each r In Range("D4:D40")
        If r.Value <> "" Or r.Offset(0, 1).Value <> "" Then
            ‘第何週？
            weeks = (Day(d) + 6) \ 7
            If r.Value = weeks Then
                Select Case r.Offset(0, 1).Value
                Case "月"
                    If Weekday(d) = vbMonday Then
                        IsWrite = True
                    End If
                Case "火"
                    If Weekday(d) = vbTuesday Then
                        IsWrite = True
                    End If
                Case "水"
                    If Weekday(d) = vbWednesday Then
                        IsWrite = True
                    End If
                Case "木"
                    If Weekday(d) = vbThursday Then
                        IsWrite = True
                    End If
                Case "金"
                    If Weekday(d) = vbFriday Then
                        IsWrite = True
                    End If
                Case "土"
                    If Weekday(d) = vbSaturday Then
                        IsWrite = True
                    End If
                Case "日"
                    If Weekday(d) = vbSunday Then
                        IsWrite = True
                    End If
                Case "全"
                    IsWrite = True
                End Select
            End If
        End If
    Next r
       
    ‘毎月Ｘ日
    For Each r In Range("F4:F40")
        If r.Value <> "" Then
            If r.Value = Day(d) Then
                IsWrite = True
            End If
        End If
    Next r
       
   
FINALLY:

End Function

Private Sub CommandButton1_Click()
    Call Exec
End Sub