和風スパゲティのレシピ

日本語でコーディングするExcelVBA

トップ > VBA問題集 > VBA課題001「スケジュール着色」回答コード

VBA課題001「スケジュール着色」回答コード

VBA問題集 書式設定・表示設定 分岐・ループ構文 プロシージャ分割 VBA

Excel・VBA総合コミュニティ「Excel-Fun.xls*」にて毎月出題される、
VBAの問題に対する私の回答ソースコードを掲載いたします。


今回掲載するコードは第1回課題共有会の課題でもあった、
「スケジュール着色」問題です。
VBA課題001「スケジュール着色」


読みやすさ重視で書いてみましたので、
よろしければご参考ください(´∀｀)

課題の内容

無色に初期化されたカレンダーに対し、
最初に数字が入っているセルと、その日付＆ヘッダーに色を付ける課題です。

◇ 元のカレンダー
元のカレンダー


◇ 初級：単色で塗る
初級：単色で塗る


◇ 中級：登場順に色分け(同日は同色)
中級：登場順に色分け

詳細は下記リンク内にある「課題説明」シートをご確認ください。


せっかくなので回答を見る前に皆さんも挑戦してみましょう。

一度自分が作ってから他の人のコードを見ることで、
学習効果が何倍にも高まります。

完成させなくても、出来る範囲で解くだけでも十分効果がありますので、
是非ともトライしてみてください！

課題共有会とは

ExcelVBAに関する1つのお題にみんなで回答し、
各自のコードを解説しあう勉強会です。


他者のコードを見る機会が少ないVBAユーザーにとって、
いろいろな手法・記法に触れることができる貴重な機会です。

もちろん聞き専での参加もできますので、
ご興味がある方はコミュニティを覗いてみてください。


今回の「スケジュール着色」に対する私以外の回答コードも公開されています。

これだけたくさんの方のソースコードを見れる機会はなかなかないと思いますので、
是非ともVBAの勉強にお役立ていただければと思います。


◇ 「スケジュール着色」の課題ファイルはこちら
Discord：★出題【VBA】#001 スケジュールへの着色


◇ 「スケジュール着色」への回答集はこちら
Discord：☆回答【VBA】#001 スケジュールへの着色


※上記はDiscord参加済みの方用のURLです
　未参加の方は下記からご参加ください！
www.limecode.jp

課題の回答ファイル

実際の回答ファイルはこちらをご覧ください。
(和風スパ)【VBA】001_スケジュールへの着色.xlsm


以下ソースコードを記載いたしますが、
上記ファイルの通り、シートオブジェクト名「WSスケジュール」「WS設定」を設定した上でのコードとなります。

ソースコード

標準モジュール：Df_定数定義

' 処理表示モード
Public Const is処理表示モード = True

' シートレイアウト
Public Const R_スケジュール見出し = 3
Public Const C_スケジュール日付 = 2
Public Const R1stスケジュール = R_スケジュール見出し + 1
Public Const C1stスケジュール = C_スケジュール日付 + 1
Public Const Color見出列の初期色 = 14277081 ' 灰

' スケジュールシートのクリア
Sub スケジュールシートの着色をクリアする(ws As Worksheet)
    With ws
        .Range(.Cells(R_スケジュール見出し, C_スケジュール日付) _
             , .Cells(R_スケジュール見出し, Get最終列(ws))).Interior.Color = Color見出列の初期色
        .Range(.Cells(R1stスケジュール, C_スケジュール日付) _
             , .Cells(Get最終行(ws), Get最終列(ws))).Interior.ColorIndex = 0
    End With
End Sub

標準モジュール：Pr_スケジュールの着色_初級

' 初級編

' 実行プロシージャ
Sub Button_色更新の実行_初級版()
    Call スケジュールシートの着色を実行する_初級(ActiveSheet)
End Sub

' メインプロシージャ
Private Sub スケジュールシートの着色を実行する_初級(ws着色シート As Worksheet)
    Dim R As Long, C As Long
    Dim 着色カラー As Long: 着色カラー = WS設定.Range("D4").Interior.Color
    
    If is処理表示モード = False Then Application.ScreenUpdating = False

    ' ■ 着色のクリア
    Call スケジュールシートの着色をクリアする(ws着色シート)

    ' △ 各列を↓方向に走査
    For C = C1stスケジュール To Get最終列(ws着色シート)
        If ws着色シート.Columns(C).Hidden = True Then GoTo 次の列へ
        
        ' 第1数値セルを検索して着色
        For R = R1stスケジュール To Get最終行(ws着色シート)
            If is処理表示モード Then Call セルを選択してs秒待機する(ws着色シート.Cells(R, C), 0.05)
            
            If Is数値入力セル(ws着色シート.Cells(R, C)) Then
                ws着色シート.Cells(R, C).Interior.Color = 着色カラー
                ws着色シート.Cells(R_スケジュール見出し, C).MergeArea.Interior.Color = 着色カラー
                ws着色シート.Cells(R, C_スケジュール日付).Interior.Color = 着色カラー
                Exit For
            End If
            
        Next

次の列へ:
    Next ' ▽ 各列を↓方向に走査

    Application.ScreenUpdating = True
    ws着色シート.Activate
    MsgBox "着色を完了しました。"

End Sub

標準モジュール：Pr_スケジュールの着色_中級

Option Explicit

' 中級編

' モジュール変数
Private ws着色シート As Worksheet

' 設定シートから順次取得する着色カラー
Function get第i番目の色(i As Long) As Long
    get第i番目の色 = WS設定.Range("F4").Offset((i - 1) Mod 4).Interior.Color
End Function

' 実行プロシージャ
Sub Button_色更新の実行_中級版()
    Set ws着色シート = ActiveSheet
    Call スケジュールシートの着色を実行する_中級
End Sub

' メインプロシージャ
Private Sub スケジュールシートの着色を実行する_中級()
    Dim R As Long, C As Long
    
    If is処理表示モード = False Then Application.ScreenUpdating = False
    
    ' ■ 着色のクリア
    Call スケジュールシートの着色をクリアする(ws着色シート)

    ' カラーの初期化
    Dim count着色 As Long: count着色 = 1
    Dim 着色カラー As Long: 着色カラー = get第i番目の色(count着色)

    ' △ 各行を→方向に走査
    Dim isその行で一度でも着色を実行した As Boolean
    For R = R1stスケジュール To Get最終行(ws着色シート)
        isその行で一度でも着色を実行した = False

        For C = C1stスケジュール To Get最終列(ws着色シート)
            
            ' ■ セルごとの処理
            If Isセルが第1数値セルなら着色を実行する(R, C, 着色カラー) Then
                isその行で一度でも着色を実行した = True
            End If
            
        Next

        ' ◇ 行内で着色が実行されたときに日付を着色し色のカウンタを進める
        If isその行で一度でも着色を実行した Then
            ws着色シート.Cells(R, C_スケジュール日付).Interior.Color = 着色カラー
            count着色 = count着色 + 1
            着色カラー = get第i番目の色(count着色)
            If is処理表示モード Then Call セルを選択してs秒待機する(ws着色シート.Cells(R, C_スケジュール日付), 0.1)
        End If
    Next ' ▽ 各行を→方向に走査

    Application.ScreenUpdating = True
    ws着色シート.Activate
    MsgBox "着色を完了しました。"

End Sub

' セルごとの処理
Private Function Isセルが第1数値セルなら着色を実行する(R As Long, C As Long, 着色カラー As Long) As Boolean
    
    Dim Targetセル As Range: Set Targetセル = ws着色シート.Cells(R, C)
    Dim 対象見出しセル As Range: Set 対象見出しセル = ws着色シート.Cells(R_スケジュール見出し, C)

    If is処理表示モード Then Call セルを選択してs秒待機する(Targetセル, 0.05)

    ' ◇ 処理条件判定
    If ws着色シート.Columns(C).Hidden = True Then Exit Function ' 列非表示
    If 対象見出しセル.Interior.Color <> Color見出列の初期色 Then Exit Function ' 見出し着色済み(数値セル既登場)
    If Is数値入力セル(Targetセル) = False Then Exit Function ' 非数値セル

    ' 対象セルと見出しを着色
    Targetセル.Interior.Color = 着色カラー
    対象見出しセル.MergeArea.Interior.Color = 着色カラー
    Isセルが第1数値セルなら着色を実行する = True

    ' ◇ 見出しが結合セルなら同時着色セルを検索
    If 対象見出しセル.MergeCells = True Then
        Dim 各見出しセル As Range
        For Each 各見出しセル In 対象見出しセル.MergeArea.Cells
            If is処理表示モード Then Call セルを選択してs秒待機する(ws着色シート.Cells(R, 各見出しセル.Column), 0.1)
            If Is数値入力セル(ws着色シート.Cells(R, 各見出しセル.Column)) Then
                ws着色シート.Cells(R, 各見出しセル.Column).Interior.Color = 着色カラー
            End If
        Next
    End If

End Function

標準モジュール：Ut_汎用関数

' 最終行・列
Function Get最終行(ws As Worksheet) As Long
    Get最終行 = ws.UsedRange.Row + ws.UsedRange.Rows.Count - 1
End Function
Function Get最終列(ws As Worksheet) As Long
    Get最終列 = ws.UsedRange.Column + ws.UsedRange.Columns.Count - 1
End Function

' 改良IsNumeric
Function Is数値入力セル(cell As Range) As Boolean _
    ' Isnumericが空セルにTrueを返す仕様をラップ
    On Error Resume Next ' エラー値はFalseとする
    Is数値入力セル = IsNumeric(cell.Value) And cell.Value <> ""
    On Error GoTo 0
End Function

' 処理表示
Sub セルを選択してs秒待機する(選択セル As Range, s As Double)
    選択セル.Select
    Application.Wait [Now()] + s / 86400
End Sub

コードの解説

今回は表自体はシンプルですが条件が多く、
どのセルをどの順で判定するのが重要な処理です。


処理順が大事ということは、ループの組み方が重要になりますが、
今回私が組んだループの方向はこんな感じになっています。

◇ 初級編
スケジュール着色初級アニメ


◇ 中級編
スケジュール着色中級アニメ


初級は「縦方向の検索」をすべての列に走らせており、
中級は「横方向の検索」を上から順に処理しています。


縦横のループ仕様をこのように組んだ理由は、
「要素間の関係が強い方(=独立でない方)を内側ループにするため」です。


初級の方は列と列の間に関係がない(=独立)なので、
「最初に登場したかどうか＝上に着色セルがあるか」
という関係がある行ループを内側にしました。


中級の方は「同日は同色」「どこかで着色があったら次の色へ」と、
列と列の間の関係の方が強かったため列ループを内側にしました。


今回のような二重ループを組む場合、
外側ループの中に処理を書こうとすると問題がより複雑になります。


逆に複雑な処理ほど一番内側のループに置くことで、
「まずはその処理をしっかりこなし、それが済んだらそれを繰り返す」
という形にできるため、問題を単純化しやすくなります。


ループの入れ子関係に迷ったら、

  • 複雑な処理ほど、一番内側のループに置くことで、
  • 要素間の関係が強い方(=独立でない方)を内側ループにする

という方針でまずは作ってみてください。



その他コード全体としては「読みやすさ」重視で組んでおります。

特に重要なのが「Isセルが第1数値セルなら着色を実行する」プロシージャで、
セルの判定と着色、その見出し・日付の着色といった、
メインロジックに直接影響のない処理をひとまとめにしました。


そうすることでメインロジックを↓のように見渡せる範囲に収めています。

' △ 各行を→方向に走査
Dim isその行で一度でも着色を実行した As Boolean
For R = R1stスケジュール To Get最終行(ws着色シート)
    isその行で一度でも着色を実行した = False

    For C = C1stスケジュール To Get最終列(ws着色シート)
        
        ' ■ セルごとの処理
        If Isセルが第1数値セルなら着色を実行する(R, C, 着色カラー) Then
            isその行で一度でも着色を実行した = True
        End If
        
    Next

    ' ◇ 行内で着色が実行されたときに日付を着色し色のカウンタを進める
    If isその行で一度でも着色を実行した Then
        ws着色シート.Cells(R, C_スケジュール日付).Interior.Color = 着色カラー
        count着色 = count着色 + 1
        着色カラー = get第i番目の色(count着色)
        If is処理表示モード Then Call セルを選択してs秒待機する(ws着色シート.Cells(R, C_スケジュール日付), 0.1)
    End If
Next ' ▽ 各行を→方向に走査

　
今回のように各要素が独立でないループ(同日は同色)では、
どうしても2重ループ内で複雑な判定が必要になりがちです。

この時ループ全体が見渡せる範囲に収まっていると、
頭を整理しながらロジックを考えやすくなります。

「ループの中身をごっそりプロシージャ化」はなかなか便利なテクニックなので、
プロシージャ分割を勉強中の方は是非修得してみて下さい。



おまけですが、先ほどのアニメのように処理順を表示する機能は、

Public変数として宣言した

' 処理表示モード
Public Const is処理表示モード = True

　
汎用関数として作成した

' 処理表示
Sub セルを選択してs秒待機する(選択セル As Range, s As Double)
    選択セル.Select
    Application.Wait [Now()] + s / 86400
End Sub

　
この二つを組み合わせて標準モジュール内に設置した

If is処理表示モード Then Call セルを選択してs秒待機する(表示セル, 0.1)

　
この3つのコードによって実装しました。

is処理表示モードをFlaseに変えるだけでOFFになってくれるので、
実際にマクロを使用するときにこの機能を切るのが簡単というのがメリットです。


Boolean型のPublic変数をフラグとして活用し、
デバッグ専用モードを作る方法はなかなか便利です。

気に入ったら採用してみてください。