パソコン同好会の7〜9月の予定日をExcel VBAで作った

麻里府パソコン同好会の 月間予定日 は、Excel で作り、[Webページとして保存]したものであるが、平成23年度から(午前中を隔週にしたため)作るのが難しくなった。で、

マクロで簡単に作りたい‥‥
と思っているばかりで進まなかったが、この二日間で[H23.07-09](タブで切り替える)の月/日だけではあるが出来るようになった。

§Excel のイメージ

まず、ワークシート関数で考え方を整理した。

  1. 4〜7行目: 予定の「標準パターン」を持つことにした。
    • キーは、「奇数曜日/偶数曜日」と「火曜日/金曜日」と2項目。こうなるとExcel では対応できない(たぶん)ことから、これらを合わせた E列 を設けた。
    • 例えば、セルE4=C4*10+D4
  2. 8行目: 講座時間の縦計。時間に差が出ないようにするための参考値。
    • 例えば、セルF8=COUNTIF(F9:F35,"○")*3、セルH8=COUNTIF(H9:H35,"○")*1.5

  3. C列: 第*曜日かで、B列の日付から日を取り出し、7で割って切り上げる。
    • 例えば、セルC9=ROUNDUP(DAY(B9)/7,0)
  4. D列: 曜日コード
    • 例えば、セルD9=WEEKDAY(B9)
  5. E列: 標準パターンを索引するためのキー
    • 例えば、セルE9=(2-MOD(C9,2))*10+D9
  6. F〜N列
    • 例えば、セルF9=INDEX($F$4:$N$7,MATCH($E9,$E$4:$E$7,0),1)

§解ったことおよび今後の課題

完成したVBA は、長いので後述した。

  1. Index関数でセルの値を取得すると、空白だった場合 0 が返る。空白を得たいのであれば、スペースを入力しておく必要がある。
  2. 8行目の講座時間の合計を計算する CouniIf関数は、その範囲の行を削除すると式が壊れる。VBA で計算式も入力できる? VBA で行う範囲か? は、次の予定を作る時に考えることにする。
  3. 今回作成した VBA は、予定日を作るだけ。
     セルの書式設定等(条件付き書式や罫線)、行列の 非表示/再表示は、別途、マクロで行う予定。

§使い方(メモ)

  1. ブックを開く
  2. 次の3ヶ月の予定を作る場合は、シートをコピーする。
  3. 9行目以下を削除する。
    • これにより、8行目の関数が壊れる。
  4. マクロ:開会日セット を実行する。
  5. 開始月を入力する。
  6. 手動で修正する。
  7. [上書き保存]する。
  8. 列、行を非表示にして、
  9. [Webページとして保存]する。


§完成したVBA

Option Explicit
Dim mbTitle As String

Public Sub 開会日セット()
Const kikan As Long = 3
Const SRow As Long = 9  '9行目
Const SCol As Long = 2  'B列
Dim SYear As Long, SMonth As Long, SDay As Long
Dim i As Long
Dim rowCTR As Long, lastRow As Long
Dim Ans01 As Long
Dim SDate As Date, EDate As Date
Dim is1st As Boolean

    mbTitle = "マクロ:開会日セット"
    If Cells(SRow, SCol) <> "" Then
        If MsgBox("データが残っています!" & vbCrLf & vbCrLf _
            & "このまま続けると「ゴミ」が残る可能性があります。" _
            , vbOKCancel + vbExclamation, mbTitle) = vbCancel Then Exit Sub
    End If
    
    SMonth = Month(Date) + 1
    SMonth = InputBox("開始月を入力してください。" _
        & vbCrLf & vbCrLf & "0 を入力すると、キャンセルします。" _
        , mbTitle, SMonth)
    If SMonth = 0 Then Exit Sub
    
    SYear = Year(Date)
    If SMonth <= Month(Date) Then SYear = SYear + 1
    SDate = DateSerial(SYear, SMonth, 1)
    EDate = DateSerial(SYear, SMonth + kikan, 0)
    is1st = True
    For i = 0 To 6
        Ans01 = Weekday(SDate)
        If Ans01 = 3 Or Ans01 = 6 Then
            If is1st Then
                is1st = False
                Cells(SRow, SCol) = SDate
            Else
                Cells(SRow + 1, SCol) = SDate
            End If
        End If
        SDate = DateAdd("d", 1, SDate)
    Next
    lastRow = 0
    For i = 0 To 1
        SDate = DateAdd("d", 7, Cells(SRow + i, SCol))
        rowCTR = SRow + i
        Do While SDate <= EDate
           rowCTR = rowCTR + 2
           Cells(rowCTR, SCol) = SDate
           SDate = DateAdd("d", 7, SDate)
        Loop
        If rowCTR > lastRow Then lastRow = rowCTR
    Next
    For i = SRow To lastRow
            '第*曜日かをセットする。
        Cells(i, SCol + 1) = Fix(Day(Cells(i, SCol)) / 7) + 1
            '曜日コードをセットする。
        Cells(i, SCol + 2) = Weekday(Cells(i, SCol))
            '検索キーをセットする。
        Cells(i, SCol + 3) = (2 - Cells(i, SCol + 1) Mod 2) * 10 + Cells(i, SCol + 2)
            'ワークシート関数 Match を使って、標準パターンの行番号を取得する。
        Ans01 = Application.WorksheetFunction _
                .Match(Cells(i, 5), Range("E4:E7"), 0)
            '標準パターンを一括コピーし、
        Range(Cells(Ans01 + 3, 6), Cells(Ans01 + 3, 14)).Select
        Selection.Copy
            'F列のセルに貼り付ける。
        Cells(i, 6).Select
        ActiveSheet.Paste
    Next
End Sub