選択セル範囲内から色がついているセルの数を数えたりする

2009.6.19

エクセルで表を作っていると、たまに「赤いセルだけカウントしたい。」とか「黄色いセルだけカウントしたい。」なんて事を思うときがあると思います。

そこで、選択セル範囲と、色番号を渡してあげると、色がついているセルの数や、割合を返してくれる標準モジュールを以下の様なステップで作ってみました。

  1. 選択セルの色番号を取得する
  2. 選択セル範囲から黄色セルの割合を取得する
  3. 再計算処理を入れる

選択セルの色番号を取得する

まずは、色番号をを調べる必要がありますので、以下の様な関数を作成して、色番号を取得してみます。

' 選択セルの色番号を取得する
' 使い方：getColorNum(セル)
Function getColorNum(cell)
    getColorNum = cell.Interior.ColorIndex
End Function

何かしらの数字が帰ってくると思います。

選択セル範囲から黄色セルの割合を取得する

色番号が取得できたかと思いますので、次に以下の様な関数を作成して、セルの範囲と、色番号を渡してあげましょう。

' 選択セル範囲から黄色セルの割合を取得する
' 使い方：getColorFraction(セル範囲,色番号)
Function getColorFraction(cell_range As Range, color_num As Long)
    Dim c_count As Long
     ' 変更があった場合に再計算させる。
    Application.Volatile
    c_count = 0
    For Each current_cell In cell_range
        If current_cell.Interior.ColorIndex = color_num Then
            c_count = c_count + 1
        End If
    Next current_cell
    getColorFraction = c_count / cell_range.Count
End Function

これで、選択範囲内の指定した色がついているセルがどれくらいの割合で含まれているかを調べることが出来ます。

VBA 便利！！

と、思ったら色を変更してもリアルタイムに更新されない！！！

これを解決するためには、次のようにする必要があります。

再計算処理を入れる

以下の様なコードを対象のシートに書いておくと、セレクションチェンジが起こったときに、シートを再計算するようになります。

' SelectionChangeでシート内再計算
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.Worksheets("シート名").Activate
     ' コピペ作業中は再計算しない。
    If Application.CutCopyMode =  Then
        ActiveSheet.Calculate
    End If
End Sub

よし！これで色を変更をしてカーソルが移動した瞬間に、再計算してくれるようになったぞ！！！

と思ったら、、、[F4]キーによる操作の繰り返しが再計算にされてしまうという弊害が、、、

今のところ僕にとって大きな弊害ではないので、様子を見ることにします。