アフィリエイト・アドセンス広告を利用しています。詳細は こちら



Excel VBA - グループ別セル色分け(2色交互・複数色)処理メモ

Excel VBA でグループ別にセルの色分け(2色交互と複数色以上のパターン)する VBA コードを公開します。

Excel と Excel Visual Basic Editor(VBE)の環境設定については 以前公開した記事 より、VBA コードの基本的な内容については こちらの記事 よりご確認ください。

Excel VBA - グループ別セル色分け(2色交互・複数色)処理メモ


グループ別セル色分け(2色交互・複数色)用サンプルファイル(xlsx ファイル)

グループ別セル色分け(2色交互・複数色)用のサンプルファイル(xlsx ファイル)を公開します。

サンプルデータは Start Point さんのところで公開しているコピペで使える都道府県一覧リスト・県庁所在地一覧 を加工しています。

こちらで作成した グループ別カラーA.xlsx ファイルグループ別カラーB.xlsx ファイル を用意しました。ファイル名リンクをクリックすると Google ドライブからダウンロードするようにしています。

グループ別カラーA.xlsx ファイル は VBA コードを実行する前の状態、グループ別カラーB.xlsx ファイル は VBA コード実行後の処理結果内容となっています。

いずれも xlsx ファイルとなっており VBA コードは含まれていません。VBA コードを実行するにはファイル拡張子が xlsm(マクロ有効ブック)となっている必要がありますが、xlsm 形式での配布は念のため避けています。

VBA コードを実行するには グループ別カラーA.xlsx ファイル をダウンロード後 xlsm 形式に保存、以降各セクションで紹介している VBA コードを各自追加して実行してもらう形としています。

VBA コードの追加方法は VBE のプロジェクトエクスプローラー(Ctrl + R キー)画面にて、開いている VBAProject(ファイル名.xlsm)→「標準モジュール」を開き、右クリックから「挿入」→「標準モジュール」でクリック、追加した標準モジュールに VBA コードを貼り付けることで動作できるようにしています。

グループ別セル色分け(2色交互・複数色)処理する VBA コードと詳細な内容については 次のセクション から説明します。

グループ別セル色分け(2色交互)処理 VBA サンプルコード 1

以下、グループ別に交互にセル色を分ける(2色交互)VBA サンプルコード 1 です。

この VBA コードはシート「グループ別カラー1」の地方区分列(A 列)を基準に判定して、セルに色を交互に振り分けていきます。コードが多少違いますが、おおまかな処理方法は こちらのサイトこちらの動画 と大体同じ内容です。

例えば地方区分の東北地方には 6県ありますが、そのすべてのセルを同じセル色にします。次の関東地方の 1都 6県には東北地方とは違うセル色に振り分けるといった感じです。上から順番に並べられている地方区分に対して交互にセルの色分け処理を繰り返します。

今回、このグループ別にセルの色を分ける方法は、下記の参考サイトですでに様々なやり方での解説があり、これらの情報の一部を参考にしてコードを作成しました。

ただ、参考サイトで紹介されているやり方では大量のデータに対して色分け処理をすると非常に時間がかかる可能性があります。気になった点として、Cells プロパティを多用して配列を使っていない(処理速度の懸念)、複数の色の管理・変更に伴うコード変更について(多分)あまり考えられていない(コードを直接編集するのが前提)、高速化のために非常に複雑なコードで構成されてる、とどれもコード内容のわかりやすさ・柔軟性・メンテナンス性・処理速度のバランスが今一歩のところで足りていないと感じたので、今回こちらのコードを作成した次第となっています。

グループ別に交互にセル色を分ける(2色交互)処理部分以外の基本的な VBA コードについては 以前公開した記事内容 を参照してください。

次のセクション からグループ別に交互にセル色を分ける(2色交互)処理がある VBA コード部分について内容を説明します。

2023// 追記

以下の VBA コードにはメモリリークを起こす可能性があります。詳細は こちら

こちら でメモリリークを対策した VBA コードを公開します。

Option Explicit

Sub AlternatingColoringGroupsofRows1()
  ' 各行のグループごとにセル色を2色交互設定

  ' 実行速度計測開始
  Dim starttime As Double
  starttime = Timer

' ----------

  ' カウンタ用変数(一見見分けにくい文字同士を組み合わせない形、i と j、m と n、o(オー) と 0(ゼロ))
  Dim i As Long

' ----------

  ' シート格納用オブジェクト変数
  Dim ws1 As Worksheet

  ' オブジェクト変数にシートセット
  Set ws1 = ThisWorkbook.Worksheets("グループ別カラー1") ' セル色反映先シートをオブジェクト変数にセット

' ----------

  ' 最終行取得用変数
  Dim maxrow1 As Long

  ' シート最終行取得して変数に格納
  maxrow1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row

  ' 最終列取得用変数
  Dim maxcol1 As Long

  ' シートの最終列取得して変数に格納
  maxcol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column

  ' セル色をクリアして初期化
  ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, maxcol1)).Interior.ColorIndex = 0

' ----------

  ' シートの指定したセル範囲を配列として格納する動的配列
  Dim data1() As Variant, data2() As Variant

  ' シートの指定した範囲内セルを配列として動的配列に格納
  data1 = ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)).Value ' シート「グループ別カラー」のカラーグループ判定対象列(A 列)を含む、カラー化対象セルを配列 data1 に代入
  data2 = ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)).Value ' カラーグループ判定用値を格納するため配列 data2 を生成(ここでは D ~ E 列(maxcol1 + 1 ~ maxcol1 + 2)の空セルを指定)

  ' Range オブジェクトを受け取り、2次元配列で返す自作関数 GetArrFromRange
'  data1 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)))
'  data2 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)))

' ----------

  ' 配列 data2 の先頭にカラーグループ判定の基準となる初期値(1)を代入
  data2(1, 1) = 1

  ' 初期値の次の値(配列)からスタートとして最終行までを for 文でループ処理(カラーグループ判定処理)
  For i = LBound(data2, 1) + 1 To UBound(data2, 1) ' 2行目から 1次元最大要素までループ処理

    ' ひとつ前の配列 data1(i - 1, 1) を data1(i, 1) と比較して一致した場合、ひとつ前の配列に代入した値を配列 data2(i, 1) に代入
    If data1(i - 1, 1) = data1(i, 1) Then
      data2(i, 1) = data2(i - 1, 1)
    ' ひとつ前の配列 data1(i - 1, 1) を data1(i, 1) と比較して一致しない場合、ひとつ前の配列に代入した値に -1 を乗算(1 → -1、-1 → 1 に変化)したものを配列 data2(i, 1) に代入
    ElseIf data1(i - 1, 1) <> data1(i, 1) Then
      data2(i, 1) = data2(i - 1, 1) * -1
    End If

  Next i

' ----------

  ' RGB 関数返り値格納用変数宣言
  Dim rgb1 As String, rgb2 As String
  
  ' RGB 関数にセル色を指定して変数に格納
  rgb1 = RGB(255, 150, 150)
  rgb2 = RGB(150, 255, 150)

  ' 配列 data2(i, 2) にカラーグループ判定処理の値(1 or -1)に応じて変数 rgb1・rgb2 を代入(デバッグ用)
  For i = LBound(data1, 1) To UBound(data1, 1)
    If data2(i, 1) = 1 Then
      data2(i, 2) = rgb1
    ElseIf data2(i, 1) = -1 Then
      data2(i, 2) = rgb2
    End If
  Next i

  ' 配列 data2 に代入したカラーグループ判定用値と RGB 関数結果をシートの任意のセル D ~ E 列に転記(デバッグ用)
'  ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)).ClearContents
'  ws1.Range("D2").Resize(UBound(data2, 1), UBound(data2, 2)).Value = data2

' ----------

  ' 地方区分別にセル色を設定
  ' 配列 data2(i, 1) のカラーグループ判定値(1 or -1)に応じて、該当セル範囲を Interior.Color プロパティで RGB 関数の値を格納した変数 rgb1・rgb2 を代入

  ' 配列 data2(i,1) に格納したカラーグループ判定値(1 or -1)を参照してセル色を指定
  For i = LBound(data1, 1) To UBound(data1, 1) ' 1次元最大要素までループ処理
  
    ' セル色をつけたくない場合は If ~ End If までをコメントアウトするか削除
    If data2(i, 1) = 1 Then
      ws1.Range(ws1.Cells(i + 1, LBound(data1, 2)), ws1.Cells(i + 1, UBound(data1, 2))).Interior.Color = rgb1
    End If
    
    ' セル色をつけたくない場合は If ~ End If までをコメントアウトするか削除
    If data2(i, 1) = -1 Then
      ws1.Range(ws1.Cells(i + 1, LBound(data1, 2)), ws1.Cells(i + 1, UBound(data1, 2))).Interior.Color = rgb2
    End If

  Next i

' ----------

  ws1.Activate ' シートアクティブ

  ' 実行速度計測結果表示
  Debug.Print Format(Timer - starttime, "0.00秒")

End Sub

カラーグループ判定用初期(基準)値の設定とカラーグループ判定処理(2色交互)

  ' 最終行取得用変数
  Dim maxrow1 As Long

  ' シート最終行取得して変数に格納
  maxrow1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row

  ' 最終列取得用変数
  Dim maxcol1 As Long

  ' シートの最終列取得して変数に格納
  maxcol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column

  ' セル色をクリアして初期化
  ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, maxcol1)).Interior.ColorIndex = 0

' ----------

  ' シートの指定したセル範囲を配列として格納する動的配列
  Dim data1() As Variant, data2() As Variant

  ' シートの指定した範囲内セルを配列として動的配列に格納
  data1 = ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)).Value ' シート「グループ別カラー」のカラーグループ判定対象列(A 列)を含む、カラー化対象セルを配列 data1 に代入
  data2 = ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)).Value ' カラーグループ判定用値を格納するため配列 data2 を生成(ここでは D ~ E 列(maxcol1 + 1 ~ maxcol1 + 2)の空セルを指定)

  ' Range オブジェクトを受け取り、2次元配列で返す自作関数 GetArrFromRange
'  data1 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)))
'  data2 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)))

' ----------

  ' 配列 data2 の先頭にカラーグループ判定の基準となる初期値(1)を代入
  data2(1, 1) = 1

  ' 初期値の次の値(配列)からスタートとして最終行までを for 文でループ処理(カラーグループ判定処理)
  For i = LBound(data2, 1) + 1 To UBound(data2, 1) ' 2行目から 1次元最大要素までループ処理

    ' ひとつ前の配列 data1(i - 1, 1) を data1(i, 1) と比較して一致した場合、ひとつ前の配列に代入した値を配列 data2(i, 1) に代入
    If data1(i - 1, 1) = data1(i, 1) Then
      data2(i, 1) = data2(i - 1, 1)
    ' ひとつ前の配列 data1(i - 1, 1) を data1(i, 1) と比較して一致しない場合、ひとつ前の配列に代入した値に -1 を乗算(1 → -1、-1 → 1 に変化)したものを配列 data2(i, 1) に代入
    ElseIf data1(i - 1, 1) <> data1(i, 1) Then
      data2(i, 1) = data2(i - 1, 1) * -1
    End If

  Next i

2次元配列を使ってカラーグループ判定用初期(基準)値の設定とカラーグループ判定処理(2色交互)をします。

38行目でワークシートを格納したオブジェクトを Range オブジェクトで、指定したセル範囲に Interior オブジェクトの ColorIndex プロパティに 0 を代入することで、色分け対象セルのセル色のみをクリアして最初に初期化しています。この処理ではセルの値は初期化されません。

やり直しなどで繰り返し処理をする際に毎回必ずセルに色を付けると決まっているのなら、セルへの色は上書きされるのでここのコードはなくても問題ありません。ここでは一応いったんセル色の情報をクリアにしてから、セルへ色を付けるという流れにしています。

47行目でカラーグループ判定値を格納するための 2次元配列 data2 を作成します。ここでは行数に地方区分数を、D ~ E 列(maxcol1 + 1maxcol1 + 2)の 2列分の空セルを指定してしています。

56行目で、47行目で作成した 2次元配列 data2 の先頭 1行 1列目にカラーグループ判定の基準となる初期値の 1 を代入しています。初期値については任意の数値で問題ありません。ここではわかりやすいように 1 にしています。この値を基準として 59~69行目の For 文内にある If 文の判定と処理をします。

59行目の For 文で 2次元配列 data2 の 1次元最大要素までループ処理をしますが、この時カウンタ変数 i の開始値に + 1 を加算しています。これは次の If 文(62~67行目)で 2次元配列 data2 のひとつ前の行のカラーグループ判定値と比較するために、カウンタ変数の開始値を + 1 加算して調整しているためです。

62行目の If 文で地方区分を格納した 2次元配列 data1(i, 1) を、同じ 2次元配列で 1行前である data1(i - 1, 1) と比較して地方区分名が一致した場合、63行目でカラーグループ判定値を格納する 2次元配列 data2(i, 1)data2(i - 1, 1) のカラーグループ判定値を代入します。

65行目では data1(i, 1)data1(i - 1, 1) と比較して地方区分名が一致しなかった場合、data1(i - 1, 1)-1 を乗算して data1(i, 1) に代入します。

これは data1(i - 1, 1) の値が 1 なら -1 に、data1(i - 1, 1) の値が -1 なら 1 に、-1 を乗算することで値をプラスマイナスに交互に変化させるためとなっています。56行目で data2(1, 1) = 1 にと初期値に 1 を設定してるため、次の地方区分は必ず -1 となって以降繰り返します。今回のデータの場合だと、北海道地方で 1、東北地方で -1、関東地方で 1 となることになります。

このような判定・計算・代入することで、一つ前の行にある地方区分名が異なる場合、カラーグループ判定値を -1 で乗算させることで 1 → -1 → 1 と交互に値を変化させることが可能です。セルに 2色交互に色分けするときの条件式に、この判定値を使います。

ここで求めたカラーグループ判定値を使って シート上の各セルに色分け処理(2色交互) をします。ちなみに こちら ではデバッグ用にカラーグループ判定値を使っています。

RGB 関数を使った RGB 値設定とデバッグ用カラーグループ判定値

  ' RGB 関数返り値格納用変数宣言
  Dim rgb1 As String, rgb2 As String
  
  ' RGB 関数にセル色を指定して変数に格納
  rgb1 = RGB(255, 150, 150)
  rgb2 = RGB(150, 255, 150)

  ' 配列 data2(i, 2) にカラーグループ判定処理の値(1 or -1)に応じて変数 rgb1・rgb2 を代入(デバッグ用)
  For i = LBound(data1, 1) To UBound(data1, 1)
    If data2(i, 1) = 1 Then
      data2(i, 2) = rgb1
    ElseIf data2(i, 1) = -1 Then
      data2(i, 2) = rgb2
    End If
  Next i

  ' 配列 data2 に代入したカラーグループ判定用値と RGB 関数結果をシートの任意のセル D ~ E 列に転記(デバッグ用)
'  ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)).ClearContents
'  ws1.Range("D2").Resize(UBound(data2, 1), UBound(data2, 2)).Value = data2

セル色の設定には RGB 関数を使います。

74行目に RGB 関数の返り値を格納するための変数を宣言します。2色交互のため変数は 2つ用意します。77~78行目で RGB 関数に RGB 値を設定して変数に代入します。

次のセクション では RGB 値を格納した変数を使ってセルへの色分け処理に使います。

以下、81~91行目のコードはデバッグ用に用意したものなので、なくてもグループ別セル色分け処理には影響ありません。

81~87行目では カラーグループ判定値(1 or -1) を使って、カラーグループ判定値を格納している 2次元配列の data2 の 2列目 data2(i, 2) に、77~78行目の RGB 関数の返り値を格納した変数を代入しています。

90~91行目に 2次元配列 data2 の 1列目のカラーグループ判定用値と、2列目に 81~87行目で代入した RGB 関数の返り値をシートに転記します。

90行目の ClearContents メソッドで転記先セル範囲をクリアしてから、91行目で 2次元配列 data2 の内容をセル D ~ E 列に転記します。(ここではコメントアウトしているためシートには転記されません)

カラーグループ判定値に応じて Interior.Color プロパティを使ったセル範囲のカラーグループ処理(2色交互)

  ' 地方区分別にセル色を設定
  ' 配列 data2(i, 1) のカラーグループ判定値(1 or -1)に応じて、該当セル範囲を Interior.Color プロパティで RGB 関数の値を格納した変数 rgb1・rgb2 を代入

  ' 配列 data2(i,1) に格納したカラーグループ判定値(1 or -1)を参照してセル色を指定
  For i = LBound(data1, 1) To UBound(data1, 1) ' 1次元最大要素までループ処理
  
    ' セル色をつけたくない場合は If ~ End If までをコメントアウトするか削除
    If data2(i, 1) = 1 Then
      ws1.Range(ws1.Cells(i + 1, LBound(data1, 2)), ws1.Cells(i + 1, UBound(data1, 2))).Interior.Color = rgb1
    End If
    
    ' セル色をつけたくない場合は If ~ End If までをコメントアウトするか削除
    If data2(i, 1) = -1 Then
      ws1.Range(ws1.Cells(i + 1, LBound(data1, 2)), ws1.Cells(i + 1, UBound(data1, 2))).Interior.Color = rgb2
    End If

  Next i

カラーグループ判定値(1 or -1) に応じて、Interior.Color プロパティを使ってセル範囲へのカラーグループ処理(2色交互)をします。

99行目の For 文で地方区分を格納した 2次元配列 data1 の 1次元最大要素までループ処理します。(地方区分数ループ処理)

102行目の If 文でカラーグループ判定値を格納した 2次元配列 data2(i, 1) の値が 1 の場合、103行目でワークシートを格納したオブジェクトの Range オブジェクトで指定したセル範囲に、Interior オブジェクトの Color プロパティに、RGB 関数の返り値を格納した変数(ここでは変数 rgb1) を代入します。

106行目の If 文も同様に、カラーグループ判定値を格納した 2次元配列 data2(i, 1) の値が -1 の場合、107行目でワークシートを格納したオブジェクトの Range オブジェクトで指定したセル範囲に、Interior オブジェクトの Color プロパティに、RGB 関数の返り値を格納した変数(ここでは変数 rgb2) を代入します。

以上のように 99行目の For 文内で 102行目と 107行目 2つの If 文による カラーグループ判定値(1 or -1) を使った条件式に応じて、103行目と 108行目の Interior.Color プロパティで地方区分別に交互にセルに色分けをします。

2次元配列で一気に各セルの色が設定できればよかったのですが、そのやり方が見つからなかったため、Interior.Color プロパティで 1つずつセル色を設定する、おそらく一般的と思われる方法となっています。データ量が多い場合はこの部分がおそらく一番処理に時間がかかると思われるので、大量のセルを塗りつぶす場合は Application.ScreenUpdating プロパティ を設定したほうが良いかもしれません。

グループ別セル色分け(2色交互)処理 VBA サンプルコード 2

以下、グループ別に交互にセル色を分ける(2色交互)VBA サンプルコード 2 です。

こちらの VBA コードは VBA サンプルコード 1 で求めた カラーグループ判定値(1 or -1) を使って、カラーグループ判定値を格納している 2次元配列の行番号を、カラーグループ判定値別に 2次元配列を用意して格納します。(関連記事 1関連記事 2

行番号を格納したカラーグループ判定値別 2次元配列をループ処理をして、指定したセル範囲へカラーグループ処理(2色交互)をします。

次のセクション から VBA サンプルコード 1 からの変更点について内容を説明します。

2023// 追記

以下の VBA コードにはメモリリークを起こす可能性があります。詳細は こちら

こちら でメモリリークを対策した VBA コードを公開します。

Option Explicit

Sub AlternatingColoringGroupsofRows2()
  ' 各行のグループごとにセル色を2色交互設定

  ' 実行速度計測開始
  Dim starttime As Double
  starttime = Timer

' ----------

  ' カウンタ用変数(一見見分けにくい文字同士を組み合わせない形、i と j、m と n、o(オー) と 0(ゼロ))
  Dim i As Long, k As Long

' ----------

  ' シート格納用オブジェクト変数
  Dim ws1 As Worksheet

  ' オブジェクト変数にシートセット
  Set ws1 = ThisWorkbook.Worksheets("グループ別カラー2") ' セル色反映先シートをオブジェクト変数にセット

' ----------

  ' 最終行取得用変数
  Dim maxrow1 As Long

  ' シート最終行取得して変数に格納
  maxrow1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row

  ' 最終列取得用変数
  Dim maxcol1 As Long

  ' シートの最終列取得して変数に格納
  maxcol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column

  ' セル色をクリアして初期化
  ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, maxcol1)).Interior.ColorIndex = 0

' ----------

  ' シートの指定したセル範囲を配列として格納する動的配列
  Dim data1() As Variant, data2() As Variant

  ' シートの指定した範囲内セルを配列として動的配列に格納
  data1 = ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)).Value ' シート「グループ別カラー」のカラーグループ判定対象列(A 列)を含む、カラー化対象セルを配列 data1 に代入
  data2 = ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)).Value ' カラーグループ判定用値を格納するため配列 data2 を生成(ここでは D ~ E 列(maxcol1 + 1 ~ maxcol1 + 2)の空セルを指定)

  ' Range オブジェクトを受け取り、2次元配列で返す自作関数 GetArrFromRange
'  data1 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)))
'  data2 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)))

' ----------

  ' 配列 data2 の先頭にカラーグループ判定の基準となる初期値(1)を代入
  data2(1, 1) = 1

  ' 初期値の次の値(配列)からスタートとして最終行までを for 文でループ処理(カラーグループ判定処理)
  For i = LBound(data2, 1) + 1 To UBound(data2, 1) ' 2行目から 1次元最大要素までループ処理

    ' ひとつ前の配列 data1(i - 1, 1) を data1(i, 1) と比較して一致した場合、ひとつ前の配列に代入した値を配列 data2(i, 1) に代入
    If data1(i - 1, 1) = data1(i, 1) Then
      data2(i, 1) = data2(i - 1, 1)
    ' ひとつ前の配列 data1(i - 1, 1) を data1(i, 1) と比較して一致しない場合、ひとつ前の配列に代入した値に -1 を乗算(1 → -1、-1 → 1 に変化)したものを配列 data2(i, 1) に代入
    ElseIf data1(i - 1, 1) <> data1(i, 1) Then
      data2(i, 1) = data2(i - 1, 1) * -1
    End If

  Next i

' ----------

  ' RGB 関数返り値格納用変数宣言
  Dim rgb1 As String, rgb2 As String
  
  ' RGB 関数にセル色を指定して変数に格納
  rgb1 = RGB(255, 150, 150)
  rgb2 = RGB(150, 255, 150)

  ' 配列 data2(i, 2) にカラーグループ判定処理の値(1 or -1)に応じて変数 rgb1・rgb2 を代入(デバッグ用)
  For i = LBound(data1, 1) To UBound(data1, 1)
    If data2(i, 1) = 1 Then
      data2(i, 2) = rgb1
    ElseIf data2(i, 1) = -1 Then
      data2(i, 2) = rgb2
    End If
  Next i

  ' 配列 data2 に代入したカラーグループ判定用値と RGB 関数結果をシートの任意のセル D ~ E 列に転記(デバッグ用)
'  ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)).ClearContents
'  ws1.Range("D2").Resize(UBound(data2, 1), UBound(data2, 2)).Value = data2

' ----------

  ' カラーグループ判定値(1 or -1)別に行番号を取得、If 文を使わずに For 文のループ処理で行番号を格納した配列を使ってセル色設定

  ' カラーグループ判定値(1 or -1)カウント用配列宣言
  Dim cntrgb() As Variant
  ' カラーグループ判定値(1 or -1)を格納する動的配列を作成
  ReDim cntrgb(1) ' cntrgb(0) - カラーグループ判定処理の値(1)合計、cntrgb(1) - カラーグループ判定処理の値(-1)合計

  For i = LBound(cntrgb) To UBound(cntrgb)
    cntrgb(i) = 0 ' 初期値 0 設定
  Next i

  ' Array 関数を使って配列の各要素に初期値 0 設定(動的配列(ReDim)や For 文を使わない)
'  cntrgb = Array(0, 0)

  ' If 文でカラーグループ判定値(1 or -1)を判定、カウントして配列 cntrgb に格納
  For i = LBound(data1, 1) To UBound(data1, 1) ' 1次元最大要素までループ処理
    If data2(i, 1) = 1 Then ' 配列 data2 の i 行 1列目がカラーグループ判定値 1 の場合
      cntrgb(0) = cntrgb(0) + 1 ' 配列 cntrgb(0) をインクリメント(+1)して配列  cntrgb(0) に格納
    End If

    If data2(i, 1) = -1 Then ' 配列 data2 の i 行 1列目がカラーグループ判定値 -1 の場合
      cntrgb(1) = cntrgb(1) + 1 ' 配列 cntrgb(1) をインクリメント(+1)して配列 cntrgb(1) に格納
    End If
  Next i

  Dim arrrgb1() As Variant ' カラーグループ判定値(1)がある行番号を配列として格納する動的配列宣言
  ReDim arrrgb1(1 To cntrgb(0), 1 To 1) ' 配列 arrrgb1 にカウントしたカラーグループ判定値(1)の個数を行数とする 2次元配列作成

  ' カラーグループ判定値(1)がある行番号を、配列 arrrgb1 に格納する処理
  k = 0 ' 配列 arrrgb1 用行番号変数の初期化
  For i = LBound(data2, 1) To UBound(data2, 1) ' 配列 data2 の 1次元最大要素までループ処理
    If data2(i, 1) = 1 Then ' 配列 data2 の i 行 1列目がカラーグループ判定値 1 の場合
      k = k + 1 ' 配列 arrrgb1 の行番号 k をインクリメント(+1)
      ' 配列 data2 の i 行目でカラーグループ判定値(1)が一致した時のループ処理変数 i(カラーグループ判定値(1)がある行番号相当)を配列 arrrgb1 の 行番号 k に代入
      arrrgb1(k, 1) = i
    End If
  Next i

  Dim arrrgb2() As Variant ' カラーグループ判定値(-1)がある行番号を配列として格納する動的配列宣言
  ReDim arrrgb2(1 To cntrgb(1), 1 To 1) ' 配列 arrrgb2 にカウントしたカラーグループ判定値(-1)の個数を行数とする 2次元配列作成

  ' カラーグループ判定値(-1)がある行番号を、配列 arrrgb2 に格納する処理
  k = 0 ' 配列 arrrgb2 用行番号変数の初期化
  For i = LBound(data2, 1) To UBound(data2, 1) ' 配列 data2 の 1次元最大要素までループ処理
    If data2(i, 1) = -1 Then ' 配列 data2 の i 行 1列目がカラーグループ判定値 -1 の場合
      k = k + 1 ' 配列 arrrgb2 の行番号 k をインクリメント(+1)
      ' 配列 data2 の i 行目でカラーグループ判定値(-1)が一致した時のループ処理変数 i(カラーグループ判定値(-1)がある行番号相当)を配列 arrrgb2 の 行番号 k に代入
      arrrgb2(k, 1) = i
    End If
  Next i

' ----------

  ' 地方区分別にセル色を設定
  ' セル色をつけたくない場合は For ~ Next i までをコメントアウトするか削除
  For i = LBound(arrrgb1, 1) To UBound(arrrgb1, 1) ' 配列 arrrgb1 の 1次元最大要素までループ処理
    ' 配列 arrrgb1 に格納したカラーグループ判定値(1)がある行番号を、色設定するセルの行番号に指定(arrrgb1(i, 1) + 1)
    ws1.Range(ws1.Cells(arrrgb1(i, 1) + 1, LBound(data1, 2)), ws1.Cells(arrrgb1(i, 1) + 1, UBound(data1, 2))).Interior.Color = rgb1
  Next i

  ' セル色をつけたくない場合は For ~ Next i までをコメントアウトするか削除
  For i = LBound(arrrgb2, 1) To UBound(arrrgb2, 1) ' 配列 arrrgb2 の 1次元最大要素までループ処理
    ' 配列 arrrgb2 に格納したカラーグループ判定値(-1)がある行番号を、色設定するセルの行番号に指定(arrrgb2(i, 1) + 1)
    ws1.Range(ws1.Cells(arrrgb2(i, 1) + 1, LBound(data1, 2)), ws1.Cells(arrrgb2(i, 1) + 1, UBound(data1, 2))).Interior.Color = rgb2
  Next i

' ----------

  ws1.Activate ' シートアクティブ

  ' 実行速度計測結果表示
  Debug.Print Format(Timer - starttime, "0.00秒")
  
End Sub

カラーグループ判定値の個数カウント

  ' カラーグループ判定値(1 or -1)別に行番号を取得、If 文を使わずに For 文のループ処理で行番号を格納した配列を使ってセル色設定

  ' カラーグループ判定値(1 or -1)カウント用配列宣言
  Dim cntrgb() As Variant
  ' カラーグループ判定値(1 or -1)を格納する動的配列を作成
  ReDim cntrgb(1) ' cntrgb(0) - カラーグループ判定処理の値(1)合計、cntrgb(1) - カラーグループ判定処理の値(-1)合計

  For i = LBound(cntrgb) To UBound(cntrgb)
    cntrgb(i) = 0 ' 初期値 0 設定
  Next i

  ' Array 関数を使って配列の各要素に初期値 0 設定(動的配列(ReDim)や For 文を使わない)
'  cntrgb = Array(0, 0)

  ' If 文でカラーグループ判定値(1 or -1)を判定、カウントして配列 cntrgb に格納
  For i = LBound(data1, 1) To UBound(data1, 1) ' 1次元最大要素までループ処理
    If data2(i, 1) = 1 Then ' 配列 data2 の i 行 1列目がカラーグループ判定値 1 の場合
      cntrgb(0) = cntrgb(0) + 1 ' 配列 cntrgb(0) をインクリメント(+1)して配列  cntrgb(0) に格納
    End If

    If data2(i, 1) = -1 Then ' 配列 data2 の i 行 1列目がカラーグループ判定値 -1 の場合
      cntrgb(1) = cntrgb(1) + 1 ' 配列 cntrgb(1) をインクリメント(+1)して配列 cntrgb(1) に格納
    End If
  Next i

カラーグループ判定値(1 or -1) を格納している 2次元配列 data2 の行番号の個数を格納する 1次元配列を作成します。そのあと、カラーグループ判定値の個数をカウントして、作成した 1次元配列に値として格納します。

ここでカウントした各カラーグループ判定値の行番号の個数(値)を、次の カラーグループ判定値別行番号を格納する 2次元配列を作成するとき、ReDim ステートメントで要素数を指定 するために必要となっています。

98行目で 2次元配列の行番号を格納する動的配列を宣言します。この動的配列を 1次元配列として扱います。

100行目の ReDim ステートメントで cntrgb(0) に カラーグループ判定値(1) の合計個数を、cntrgb(1) に カラーグループ判定値(-1) の合計個数を格納します。102~104行目の For 文で一応初期化をしています。

ReDim ステートメントと For 文を使わない別の方法として、107行目のように Array 関数を使って配列の要素数作成と初期値を設定する書き方があります。

110行目の For 文で 2次元配列 data1 の 1次元最大要素までループ処理を行います。この For 文内で 111行目と 115行目で If 文を使って 2次元配列 data2 の i 行 1 列目に格納した カラーグループ判定値(1 or -1) の判定を行い、条件が一致したら 112行目か 116行目でカウントして 1次元配列 cntrgb の指定した要素番号に格納します。

関連記事 関連記事

カラーグループ判定値に一致した行番号格納

  Dim arrrgb1() As Variant ' カラーグループ判定値(1)がある行番号を配列として格納する動的配列宣言
  ReDim arrrgb1(1 To cntrgb(0), 1 To 1) ' 配列 arrrgb1 にカウントしたカラーグループ判定値(1)の個数を行数とする 2次元配列作成

  ' カラーグループ判定値(1)がある行番号を、配列 arrrgb1 に格納する処理
  k = 0 ' 配列 arrrgb1 用行番号変数の初期化
  For i = LBound(data2, 1) To UBound(data2, 1) ' 配列 data2 の 1次元最大要素までループ処理
    If data2(i, 1) = 1 Then ' 配列 data2 の i 行 1列目がカラーグループ判定値 1 の場合
      k = k + 1 ' 配列 arrrgb1 の行番号 k をインクリメント(+1)
      ' 配列 data2 の i 行目でカラーグループ判定値(1)が一致した時のループ処理変数 i(カラーグループ判定値(1)がある行番号相当)を配列 arrrgb1 の 行番号 k に代入
      arrrgb1(k, 1) = i
    End If
  Next i

  Dim arrrgb2() As Variant ' カラーグループ判定値(-1)がある行番号を配列として格納する動的配列宣言
  ReDim arrrgb2(1 To cntrgb(1), 1 To 1) ' 配列 arrrgb2 にカウントしたカラーグループ判定値(-1)の個数を行数とする 2次元配列作成

  ' カラーグループ判定値(-1)がある行番号を、配列 arrrgb2 に格納する処理
  k = 0 ' 配列 arrrgb2 用行番号変数の初期化
  For i = LBound(data2, 1) To UBound(data2, 1) ' 配列 data2 の 1次元最大要素までループ処理
    If data2(i, 1) = -1 Then ' 配列 data2 の i 行 1列目がカラーグループ判定値 -1 の場合
      k = k + 1 ' 配列 arrrgb2 の行番号 k をインクリメント(+1)
      ' 配列 data2 の i 行目でカラーグループ判定値(-1)が一致した時のループ処理変数 i(カラーグループ判定値(-1)がある行番号相当)を配列 arrrgb2 の 行番号 k に代入
      arrrgb2(k, 1) = i
    End If
  Next i

カラーグループ判定値(1 or -1)カウントした個数の値を格納した 1次元配列 cntrgb を使って、カラーグループ判定値の行番号を格納する 2次元配列の作成と行番号を格納します。

以下、カラーグループ判定値 1 または -1 に応じて処理を分けます。カラーグループ判定値 1 では 120~131行目のコードで、カラーグループ判定値 -1 では 133~144行目のコードで処理をします。どちらのコードも同じ処理の流れとなっており、違いは変数名や使用する配列の要素番号、条件式の値となっています。

まずはカラーグループ判定値 1 の場合の処理について説明します。(120~131行目)

120行目でカラーグループ判定値 1 がある行番号を 2次元配列として格納する動的配列を宣言します。

121行目で ReDim ステートメントで動的配列の要素数を指定します。1次元と 2次元の開始・終了値を指定して 2次元配列を作成します。その際に 1次元の要素番号の終了値に カラーグループ判定値 1 の個数の値を格納した 1次元配列 cntrgb(0) を指定します。

これで作成した 2次元配列 arrrgb1 にカラーグループ判定値 1 がある行番号を格納する準備が整います。

124行目でカウンタ変数 k を 0 で初期化します。このカウンタ変数 k は先ほど作成した 2次元配列 arrrgb1 の 1次元(行番号)を操作するのに使用します。

125行目の For 文でカラーグループ判定値を格納した 2次元配列 data2 の 1次元の最大要素までループ処理します。なお、ここの For 文で使うカウンタ変数 i が行番号相当になって 129行目で使用します。

126行目の If 文で 2次元配列 data2 の i 行 1列目に格納したカラーグループ判定値 が 1 の場合、127行目でカウンタ変数 k をインクリメントして、129行目の 2次元配列 arrrgb1 の k 行 1 列目にカウンタ変数 i(行番号相当)を代入します。

上記の 120~131行目のループ処理でカラーグループ判定値 1 が格納されている 2次元配列 data2 の行番号を、別の 2次元配列 arrrgb1 に格納することができます。

133~144行目はカラーグループ判定値 -1 用の処理コードです。処理の流れとしては 120~131行目のカラーグループ判定値 1 の時と同じです。以下、コード内容の相違点についてかんたんに説明します。

別の動的配列を作成と使用(arrrgb1 → arrrgb2)、ReDim ステートメントで 1次元の終了値に指定する 1次元配列 cntrgb の要素番号 cntrgb(0) → cntrgb(1) に変更、If 文の条件式の変更(data2(i, 1) = 1data2(i, 1) = -1)となっています。

次のセクション ではカラーグループ判定値別行番号を格納した 2次元配列を使って、シート上の各セルに色分け処理(2色交互)をします。

カラーグループ判定値の行番号に応じて Interior.Color プロパティを使ったセル範囲のカラーグループ処理(2色交互)

  ' 地方区分別にセル色を設定
  ' セル色をつけたくない場合は For ~ Next i までをコメントアウトするか削除
  For i = LBound(arrrgb1, 1) To UBound(arrrgb1, 1) ' 配列 arrrgb1 の 1次元最大要素までループ処理
    ' 配列 arrrgb1 に格納したカラーグループ判定値(1)がある行番号を、色設定するセルの行番号に指定(arrrgb1(i, 1) + 1)
    ws1.Range(ws1.Cells(arrrgb1(i, 1) + 1, LBound(data1, 2)), ws1.Cells(arrrgb1(i, 1) + 1, UBound(data1, 2))).Interior.Color = rgb1
  Next i

  ' セル色をつけたくない場合は For ~ Next i までをコメントアウトするか削除
  For i = LBound(arrrgb2, 1) To UBound(arrrgb2, 1) ' 配列 arrrgb2 の 1次元最大要素までループ処理
    ' 配列 arrrgb2 に格納したカラーグループ判定値(-1)がある行番号を、色設定するセルの行番号に指定(arrrgb2(i, 1) + 1)
    ws1.Range(ws1.Cells(arrrgb2(i, 1) + 1, LBound(data1, 2)), ws1.Cells(arrrgb2(i, 1) + 1, UBound(data1, 2))).Interior.Color = rgb2
  Next i

こちらで 2次元配列に格納したカラーグループ判定値の行番号 に応じて、Interior.Color プロパティを使ったセル範囲のカラーグループ処理(2色交互)をします。

150行目の For 文でカラーグループ判定値 1 の行番号を格納した、2次元配列 arrrgb1 の 1次元最大要素までループ処理します。

152行目でワークシートを格納したオブジェクトの Range オブジェクトで指定したセル範囲の Interior オブジェクトの Color プロパティに、RGB 関数の返り値を格納した変数(ここでは変数 rgb1) を代入します。

この部分は VBA サンプルコード 1 のカラーグループ処理(2色交互) と同じですが、Cells プロパティの行番号を i + 1 から行番号を格納した 2次元配列の arrrgb1(i, 1) に変更しています。

156行目と158行目も同じコード内容で、違いは 2次元配列 を arrrgb2 に、Interior オブジェクトの Color プロパティに変数 rgb2 を代入している点です。こちらはカラーグループ判定値 -1 の行番号に対してセルに色を付けています。

このようにすることで VBA サンプルコード 1 のカラーグループ処理(2色交互) では If 文で都度カラーグループ判定値に応じて上から順番にセルに色を付ける方法だったのに対して、こちらは 2次元配列に格納したカラーグループ判定値の行番号 から直接色を付ける対象セルを指定することで、If 文で判定することなく For 文で対象の行番号に対して一気にセルに色を付けることができます。

RGB 値からセル色設定 VBA サンプルコード

以下、シート上の各セルにある RGB 値(0~255)からセル色を設定する VBA サンプルコードです。

こちらは次の グループ別セル色分け(複数色)処理 VBA サンプルコード で使用する、シート「RGB値シート」の補足説明となります。

グループ別セル色分け(複数色)処理 VBA サンプルコード ではこのコードは使用しませんが、セルに任意の値に設定した複数の RGB 値による、文字色とセル色の組み合わせをまとめてチェックすることができます。

48行目に RGB 値があるセル範囲を格納して 2次元配列 data1 を作成します。

52行目の For 文で 2次元配列 data1 の 1次元最大要素までループ処理します。

53行目で指定した各セルに文字を入力(ここでは Sample)、54行目に 2次元配列 data1 の各要素番号に格納した RGB 値を RGB 関数にセットして、Interior.Color プロパティを使ってセル範囲への色を付けます。

2023// 追記

以下の VBA コードにはメモリリークを起こす可能性があります。詳細は こちら

こちら でメモリリークを対策した VBA コードを公開します。

Option Explicit

Sub RGBColor()
  ' シート「RGB値」各セルに入力した RGB 値から RGB 関数でセルに色設定

  ' 実行速度計測開始
  Dim starttime As Double
  starttime = Timer

' ----------

  ' カウンタ用変数(一見見分けにくい文字同士を組み合わせない形、i と j、m と n、o(オー) と 0(ゼロ))
  Dim i As Long

' ----------

  ' シート格納用オブジェクト変数
  Dim ws1 As Worksheet

  ' オブジェクト変数にシートセット
  Set ws1 = ThisWorkbook.Worksheets("RGB値シート") ' シートをオブジェクト変数にセット

' ----------

  ' 最終行取得用変数
  Dim maxrow1 As Long

  ' シート最終行取得して変数に格納
  maxrow1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row

  ' 最終列取得用変数
  Dim maxcol1 As Long

  ' シートの最終列取得して変数に格納
  maxcol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column

' ----------

  ' D 列のセル色をクリアして初期化
  ws1.Range(ws1.Cells(2, maxcol1), ws1.Cells(maxrow1, maxcol1)).Interior.ColorIndex = 0

' ----------

  ' シートの指定したセル範囲を配列として格納する動的配列
  Dim data1() As Variant

  ' シートの指定した範囲内セルを配列として動的配列に格納
  data1 = ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)).Value

' ----------

  For i = LBound(data1, 1) To UBound(data1, 1)
    ws1.Cells(i + 1, maxcol1).Value = "Sample"
    ws1.Cells(i + 1, maxcol1).Interior.Color = RGB(data1(i, 1), data1(i, 2), data1(i, 3))
  Next i

' ----------

  ws1.Activate ' シートアクティブ

  ' 実行速度計測結果表示
  Debug.Print Format(Timer - starttime, "0.00秒")

End Sub

グループ別セル色分け(複数色)処理 VBA サンプルコード

以下、グループ別に交互にセル色を分ける(複数色)VBA サンプルコードです。

VBA サンプルコード 1 および VBA サンプルコード 2 ではグループ別にカラーグループ判定値を決めて 2色交互にセル色を分けていましたが、複数の色を増やして管理するとなると都度コードの追加・変更が必要となり、使い勝手の悪い柔軟性のないコードとなってしまいます。

そこで シート「RGB値シート」の各セルに RGB 値をあらかじめ設定 しておき、シート上に設定した RGB 値のカラー数に応じてセル色を振り分けるコードを作成しました。

このコード内容であればシート上の RGB 値を追加・変更するだけでコード内容を修正することなく、グループ別のカラーを柔軟に設定・変更できるようになります。

次のセクション から VBA サンプルコード 1 および VBA サンプルコード 2 からの変更点について内容を説明します。

2023// 追記

以下の VBA コードにはメモリリークを起こす可能性があります。詳細は こちら

こちら でメモリリークを対策した VBA コードを公開します。

Option Explicit

Sub AlternatingColoringGroupsofRows3()
  ' 各行のグループごとにセル色を複数設定

  ' 実行速度計測開始
  Dim starttime As Double
  starttime = Timer

' ----------

  ' カウンタ用変数(一見見分けにくい文字同士を組み合わせない形、i と j、m と n、o(オー) と 0(ゼロ))
  Dim i As Long, k As Long, p As Long

' ----------

  ' シート格納用オブジェクト変数
  Dim ws1 As Worksheet, ws2 As Worksheet

  ' オブジェクト変数にシートセット
  Set ws1 = ThisWorkbook.Worksheets("グループ別カラー3") ' セル色反映先シートをオブジェクト変数にセット
  Set ws2 = ThisWorkbook.Worksheets("RGB値シート") ' RGB 関数用 RGB 値シートをオブジェクト変数にセット

' ----------

  ' 最終行取得用変数
  Dim maxrow1 As Long, maxrow2 As Long

  ' シート最終行取得して変数に格納
  maxrow1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row
  maxrow2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row

  ' 最終列取得用変数
  Dim maxcol1 As Long
  Dim maxcol2 As Long

  ' シートの最終列取得して変数に格納
  maxcol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
  maxcol2 = ws2.Cells(1, Columns.Count).End(xlToLeft).Column

  ' セル色をクリアして初期化
  ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, maxcol1)).Interior.ColorIndex = 0

' ----------

  ' シートの指定したセル範囲を配列として格納する動的配列
  Dim data1() As Variant, data2() As Variant, data3() As Variant

  ' シートの指定した範囲内セルを配列として動的配列に格納
  data1 = ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)).Value ' シート「グループ別カラー」のカラーグループ判定対象列(A 列)を含む、カラー化対象セルを配列 data1 に代入
  data2 = ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)).Value ' カラーグループ判定用値を格納するため配列 data2 を生成(ここでは D ~ E 列(maxcol1 + 1 ~ maxcol1 + 2)の空セルを指定)
  data3 = ws2.Range(ws2.Cells(2, 1), ws2.Cells(maxrow2, maxcol2 - 1)).Value ' シート「RGB値」の各セルにある RGB 値(0 ~ 255)を配列 data3 に代入(D 列(色見本)除外のため maxcol2 - 1 で C 列まで指定)

  ' Range オブジェクトを受け取り、2次元配列で返す自作関数 GetArrFromRange
'  data1 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)))
'  data2 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)))
'  data3 = GetArrFromRange.GetArrFromRange(ws2.Range(ws2.Cells(2, 1), ws2.Cells(maxrow2, maxcol2 - 1)))

' ----------

  ' 配列 data2 の先頭にカラーグループ判定の基準となる初期値(1)を代入
  data2(1, 1) = 1

  ' 初期値の次の値(配列)からスタートとして最終行までを for 文でループ処理(カラーグループ判定処理)
  For i = LBound(data2, 1) + 1 To UBound(data2, 1) ' 2行目から 1次元最大要素までループ処理

    ' ひとつ前の配列 data1(i - 1, 1) を data1(i, 1) と比較して一致した場合、ひとつ前の配列に代入した値を配列 data2(i, 1) に代入
    If data1(i - 1, 1) = data1(i, 1) Then
      data2(i, 1) = data2(i - 1, 1)
    ' ひとつ前の配列 data1(i - 1, 1) を data1(i, 1) と比較して一致しない場合、ひとつ前の配列に代入した値にインクリメント(+1)したものを配列 data2(i, 1) に代入
    ElseIf data1(i - 1, 1) <> data1(i, 1) Then
      data2(i, 1) = data2(i - 1, 1) + 1
    End If

    ' data2(i, 1) に代入した値がシート「RGB値」に設定した色数(=行数(maxrow2 - 1))より多い場合、data2(i, 1) に 1 を代入
    ' 3色設定の場合、data2(i, 1) が 4 になったときに 1 を代入(カラーグループ判定値を 1 → 2 → 3 → 1 → 2 のようにループ処理)
    If data2(i, 1) > maxrow2 - 1 Then
      data2(i, 1) = 1
    End If

  Next i

' ----------
  
  ' RGB 関数に RGB 値をセットして配列 data(i, 2) に代入

  For i = LBound(data2, 1) To UBound(data2, 1) ' 1次元最大要素までループ処理

    ' 配列 data2(i, 1) のカラーグループ判定値(1 or 2 or 3)を変数 k に代入
    k = data2(i, 1)
    
    ' 配列 data2(i, 2) に RGB 値をセットした RGB 関数の結果を代入
    ' RGB 値は配列 data3 の行列を指定
    ' 配列 data3 の行には変数 k の値(カラーグループ判定値 1 or 2 or 3)で行指定
    ' 配列 data3 の列には 1・2・3 の値を順番に指定、それぞれの値は配列 data3 の 1 ~ 3 列に格納された RGB 値がある列
    data2(i, 2) = RGB(data3(k, 1), data3(k, 2), data3(k, 3))

  Next i

  ' 配列 data2 に代入したカラーグループ判定用値と RGB 関数結果をシートの任意のセル D ~ E 列に転記(デバッグ用)
'  ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)).ClearContents
'  ws1.Range("D2").Resize(UBound(data2, 1), UBound(data2, 2)).Value = data2

' ----------

  ' カラーグループ判定値(1 or 2 or 3)別に行番号を取得、セル色設定には If 文による判定処理を使わずに For 文のループ処理で行番号を格納した配列を使用

  ' カラーグループ判定値(1 or 2 or 3)別カウント用変数宣言
  Dim cntrgb As Long
  
  ' カラーグループ判定値(1 or 2 or 3)がある行番号を配列として格納する動的配列宣言
  Dim arrrgb() As Variant

  For p = LBound(data3, 1) To UBound(data3, 1) ' 1次元最大要素までループ処理(色数分処理)

    cntrgb = 0 ' カラーグループ判定値(1 or 2 or 3)別カウント変数、初期値 0 設定

    ' If 文でカラーグループ判定値をカウントして合計を変数 cntrgb に格納
    For i = LBound(data1, 1) To UBound(data1, 1) ' 1次元最大要素までループ処理
      If data2(i, 1) = p Then ' 配列 data2 の i 行 1列目のカラーグループ判定値が、変数 p(1 or 2 or 3)と同じ場合
        cntrgb = cntrgb + 1 ' 変数 cntrgb をインクリメント(+1)して変数 cntrgb に格納
      End If
    Next i

    ' 配列 arrrgb にカウントしたカラーグループ判定値(1 or 2 or 3)の個数を行数とする 2次元動的配列作成
    ReDim arrrgb(1 To cntrgb, 1 To 1) ' カラーグループ判定値(1 or 2 or 3)別に動的配列を作成、変数 p を使った For 文の処理ごとに実行(同時に初期化)

    ' カラーグループ判定値(1 or 2 or 3)がある行番号を、配列 arrrgb に格納する処理
    k = 0 ' 配列 arrrgb の行番号用として変数 k を 0 で初期化
    For i = LBound(data2, 1) To UBound(data2, 1) ' 配列 data2 の 1次元最大要素までループ処理
      If data2(i, 1) = p Then ' 配列 data2 の i 行 1列目のカラーグループ判定値が、変数 p(1 or 2 or 3)と同じ場合
        k = k + 1 ' 配列 arrrgb の行番号 k をインクリメント(+1)
        ' 配列 data2 の i 行 1列目でカラーグループ判定値(1 or 2 or 3)が一致した時のループ処理変数 i(カラーグループ判定値(1 or 2 or 3)がある行番号相当)を配列 arrrgb の 行番号 k に代入
        arrrgb(k, 1) = i
      End If
    Next i

    ' 地方区分別にセル色を設定
    For i = LBound(arrrgb, 1) To UBound(arrrgb, 1) ' 配列 arrrgb の 1次元最大要素までループ処理
      ' 配列 arrrgb に格納したカラーグループ判定値(1 or 2 or 3)がある行番号を、色設定するセルの行番号に指定(arrrgb(i, 1) + 1)
      ws1.Range(ws1.Cells(arrrgb(i, 1) + 1, LBound(data1, 2)), ws1.Cells(arrrgb(i, 1) + 1, UBound(data1, 2))).Interior.Color = data2(arrrgb(i, 1), 2)
    Next i

  Next p

' ----------

  ws1.Activate ' シートアクティブ

  ' 実行速度計測結果表示
  Debug.Print Format(Timer - starttime, "0.00秒")
  
End Sub

RGB 値格納用 2次元配列作成

  ' シートの指定したセル範囲を配列として格納する動的配列
  Dim data1() As Variant, data2() As Variant, data3() As Variant

  ' シートの指定した範囲内セルを配列として動的配列に格納
  data1 = ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)).Value ' シート「グループ別カラー」のカラーグループ判定対象列(A 列)を含む、カラー化対象セルを配列 data1 に代入
  data2 = ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)).Value ' カラーグループ判定用値を格納するため配列 data2 を生成(ここでは D ~ E 列(maxcol1 + 1 ~ maxcol1 + 2)の空セルを指定)
  data3 = ws2.Range(ws2.Cells(2, 1), ws2.Cells(maxrow2, maxcol2 - 1)).Value ' シート「RGB値」の各セルにある RGB 値(0 ~ 255)を配列 data3 に代入(D 列(色見本)除外のため maxcol2 - 1 で C 列まで指定)

  ' Range オブジェクトを受け取り、2次元配列で返す自作関数 GetArrFromRange
'  data1 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)))
'  data2 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)))
'  data3 = GetArrFromRange.GetArrFromRange(ws2.Range(ws2.Cells(2, 1), ws2.Cells(maxrow2, maxcol2 - 1)))

シート「RGB値」のセルにある RGB 値を格納した 2次元配列を作成します。

52行目でシート「RGB値」の各セルにある RGB 値(0 ~ 255)を動的配列 data3 に代入して 2次元配列を作成します。

シート「RGB値」の D 列 色見本 はセル色を確認するために用意したもので不要です。これにより D 列を除外するため、Range オブジェクトの Cells プロパティの終了セルに、最終列から 1 を引いた(maxcol2 - 1)C 列までを指定しています。

カラーグループ判定用初期(基準)値の設定とカラーグループ判定処理(複数色)

  ' 配列 data2 の先頭にカラーグループ判定の基準となる初期値(1)を代入
  data2(1, 1) = 1

  ' 初期値の次の値(配列)からスタートとして最終行までを for 文でループ処理(カラーグループ判定処理)
  For i = LBound(data2, 1) + 1 To UBound(data2, 1) ' 2行目から 1次元最大要素までループ処理

    ' ひとつ前の配列 data1(i - 1, 1) を data1(i, 1) と比較して一致した場合、ひとつ前の配列に代入した値を配列 data2(i, 1) に代入
    If data1(i - 1, 1) = data1(i, 1) Then
      data2(i, 1) = data2(i - 1, 1)
    ' ひとつ前の配列 data1(i - 1, 1) を data1(i, 1) と比較して一致しない場合、ひとつ前の配列に代入した値にインクリメント(+1)したものを配列 data2(i, 1) に代入
    ElseIf data1(i - 1, 1) <> data1(i, 1) Then
      data2(i, 1) = data2(i - 1, 1) + 1
    End If

    ' data2(i, 1) に代入した値がシート「RGB値」に設定した色数(=行数(maxrow2 - 1))より多い場合、data2(i, 1) に 1 を代入
    ' 3色設定の場合、data2(i, 1) が 4 になったときに 1 を代入(カラーグループ判定値を 1 → 2 → 3 → 1 → 2 のようにループ処理)
    If data2(i, 1) > maxrow2 - 1 Then
      data2(i, 1) = 1
    End If

  Next i

2次元配列を使ってカラーグループ判定用初期(基準)値の設定とカラーグループ判定処理(複数色)をします。

基本的に VBA サンプルコード 1 のカラーグループ判定用初期(基準)値の設定とカラーグループ判定処理(2色交互) の 56~69行目の内容と同じです。

以下相違点について説明します。

72行目でカラーグループ判定値を -1 の乗算から +1 の加算に変更しています。-1 の場合は交互に値が変化するため 2色までしか管理できませんでしたが、加算することで複数色のカラーグループ判定値を管理できるようにします。

77行目の If 文で 2次元配列 data2(i, 1) に代入したカラーグループ判定値が、シート「RGB値」に設定した色数(=行数(maxrow2 - 1))より大きい場合、78行目で data2(i, 1) に 1 を代入して初期化します。

今回の 3色設定の場合、data2(i, 1) が 4 になったときに 1 を代入を代入することで、カラーグループ判定値を 1 → 2 → 3 → 1 → 2 →・・・のようにループさせています。

このカラーグループ判定値は RGB 値を格納した 2次元配列 data3 の行番号と同じになる ようにしています。3色の場合は 2次元配列の行番号 1~3行目の各列に RGB 値を格納ということになります。77~79行目で最終行を閾値として行番号判定と初期化を入れることで、RGB 値が存在しない行番号を指定しないようにしています。これを 次に使います

以上のようなコードで処理をすることでシート上の RGB 値を設定したセルを追加しても、カラーグループ判定値を加算・初期化を繰り返すので、コードを新たに追加・変更する必要がありません。

カラーグループ判定値を使って RGB 関数の RGB 値を 2次元配列に設定

  ' RGB 関数に RGB 値をセットして配列 data(i, 2) に代入

  For i = LBound(data2, 1) To UBound(data2, 1) ' 1次元最大要素までループ処理

    ' 配列 data2(i, 1) のカラーグループ判定値(1 or 2 or 3)を変数 k に代入
    k = data2(i, 1)
    
    ' 配列 data2(i, 2) に RGB 値をセットした RGB 関数の結果を代入
    ' RGB 値は配列 data3 の行列を指定
    ' 配列 data3 の行には変数 k の値(カラーグループ判定値 1 or 2 or 3)で行指定
    ' 配列 data3 の列には 1・2・3 の値を順番に指定、それぞれの値は配列 data3 の 1 ~ 3 列に格納された RGB 値がある列
    data2(i, 2) = RGB(data3(k, 1), data3(k, 2), data3(k, 3))

  Next i

  ' 配列 data2 に代入したカラーグループ判定用値と RGB 関数結果をシートの任意のセル D ~ E 列に転記(デバッグ用)
'  ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)).ClearContents
'  ws1.Range("D2").Resize(UBound(data2, 1), UBound(data2, 2)).Value = data2

カラーグループ判定値(複数色) を使って、RGB 関数の RGB 値を 2次元配列に格納・設定します。

コードの内容は グループ別セル色分け(2色交互)処理 VBA サンプルコード 1 の RGB 関数を使った RGB 値設定とデバッグ用カラーグループ判定値処理 を一部変更したものになります。

87行目の For 文でカラーグループ判定値を格納した 2次元配列 data2 の 1次元最大要素までループ処理します。

90行目で 2次元配列 data2 カウンタ変数 i 行 1 列目のカラーグループ判定値(今回の場合 1 or 2 or 3)を変数 k に代入します。この変数 k は次の 2次元配列の行番号指定に使います。

96行目に 2次元配列 data2 カウンタ変数 i 行 2 列目に RGB 関数の返り値を代入します。RGB 関数の RGB 値は 2次元配列 data3 に格納してあるので、行番号(変数 k)と列番号(1~3)で指定して参照しています。

2次元配列 data3 の行には変数 k の値(カラーグループ判定値 1 or 2 or 3)で行番号を指定、列には 1(R)・2(G)・3(B)それぞれの列番号を順番に指定することで、2次元配列 data3 の変数 k 行目にある 1 ~ 3 列に格納された RGB 値(0~255)を RGB 関数に設定しています。

以上の方法でシート上の RGB 値を 2次元配列に格納して、2次元配列に格納したカラーグループ判定値を行番号として指定することで、シート「RGB値」でカラー数を増減してもコード内容を追加・変更することなく、RGB 関数の内容を 2次元配列へ代入することができます。

カラーグループ判定値の行番号に応じて Interior.Color プロパティを使ったセル範囲のカラーグループ処理(複数色)

  ' カラーグループ判定値(1 or 2 or 3)別に行番号を取得、セル色設定には If 文による判定処理を使わずに For 文のループ処理で行番号を格納した配列を使用

  ' カラーグループ判定値(1 or 2 or 3)別カウント用変数宣言
  Dim cntrgb As Long
  
  ' カラーグループ判定値(1 or 2 or 3)がある行番号を配列として格納する動的配列宣言
  Dim arrrgb() As Variant

  For p = LBound(data3, 1) To UBound(data3, 1) ' 1次元最大要素までループ処理(色数分処理)

    cntrgb = 0 ' カラーグループ判定値(1 or 2 or 3)別カウント変数、初期値 0 設定

    ' If 文でカラーグループ判定値をカウントして合計を変数 cntrgb に格納
    For i = LBound(data1, 1) To UBound(data1, 1) ' 1次元最大要素までループ処理
      If data2(i, 1) = p Then ' 配列 data2 の i 行 1列目のカラーグループ判定値が、変数 p(1 or 2 or 3)と同じ場合
        cntrgb = cntrgb + 1 ' 変数 cntrgb をインクリメント(+1)して変数 cntrgb に格納
      End If
    Next i

    ' 配列 arrrgb にカウントしたカラーグループ判定値(1 or 2 or 3)の個数を行数とする 2次元動的配列作成
    ReDim arrrgb(1 To cntrgb, 1 To 1) ' カラーグループ判定値(1 or 2 or 3)別に動的配列を作成、変数 p を使った For 文の処理ごとに実行(同時に初期化)

    ' カラーグループ判定値(1 or 2 or 3)がある行番号を、配列 arrrgb に格納する処理
    k = 0 ' 配列 arrrgb の行番号用として変数 k を 0 で初期化
    For i = LBound(data2, 1) To UBound(data2, 1) ' 配列 data2 の 1次元最大要素までループ処理
      If data2(i, 1) = p Then ' 配列 data2 の i 行 1列目のカラーグループ判定値が、変数 p(1 or 2 or 3)と同じ場合
        k = k + 1 ' 配列 arrrgb の行番号 k をインクリメント(+1)
        ' 配列 data2 の i 行 1列目でカラーグループ判定値(1 or 2 or 3)が一致した時のループ処理変数 i(カラーグループ判定値(1 or 2 or 3)がある行番号相当)を配列 arrrgb の 行番号 k に代入
        arrrgb(k, 1) = i
      End If
    Next i

    ' 地方区分別にセル色を設定
    For i = LBound(arrrgb, 1) To UBound(arrrgb, 1) ' 配列 arrrgb の 1次元最大要素までループ処理
      ' 配列 arrrgb に格納したカラーグループ判定値(1 or 2 or 3)がある行番号を、色設定するセルの行番号に指定(arrrgb(i, 1) + 1)
      ws1.Range(ws1.Cells(arrrgb(i, 1) + 1, LBound(data1, 2)), ws1.Cells(arrrgb(i, 1) + 1, UBound(data1, 2))).Interior.Color = data2(arrrgb(i, 1), 2)
    Next i

  Next p

カラーグループ判定値を格納した 2次元配列RGB 関数の RGB 値を格納した 2次元配列 を使って、Interior.Color プロパティでセル範囲のカラーグループ処理(複数色)をします。

大まかな処理の流れとしてシート「RGB値」に設定した RGB 値の行数分ループ処理を行い、その中でカラーグループ判定値別の行番号を調べ、その行番号情報をもとに各セルに RGB 値を代入して色を付けます。

コード内容は グループ別セル色分け(2色交互)処理 VBA サンプルコード 2カラーグループ判定値に一致した行番号格納 と、カラーグループ判定値の行番号に応じて Interior.Color プロパティを使ったセル範囲のカラーグループ処理(2色交互) を組み合わせて複数色に対応したものとなっています。

109行目にカラーグループ判定値(1 or 2 or 3)をカウントする変数を宣言します。114行目の For 文(シート「RGB値」行数分ループ処理)内で 0 に初期化(116行目)しているので、カラーグループ判定値別の変数を複数用意する必要はありません。

112行目でカラーグループ判定値(1 or 2 or 3)がある行番号を 2次元配列に格納する動的配列を宣言します。こちらも 114行目の For 文(シート「RGB値」行数分ループ処理)内で ReDim ステートメントで 2次元配列を作成(126行目)しているので、カラーグループ判定値別動的配列を複数用意する必要はありません。


114行目の For 文でシート「RGB値」を格納した 2次元配列 data3 の 1次元最大要素までループ処理をします。ここのカウンタ変数 p の値はカラーグループ判定値(2次元配列 data2)と一致するため、以下の処理は各カラーグループ判定値別に行うことになります。


続けて 119行目の For 文で地方区分を格納した 2次元配列 data1 の 1次元最大要素までループ処理をします。

120行目の If 文で 2次元配列 data2 の i 行 1列目のカラーグループ判定値が、114行目のカウンタ変数 p(1 or 2 or 3)と同じ場合、109行目で宣言した変数 cntrgb(116行目で 0 に初期化)をインクリメントして変数 cntrgb に格納します。

これを繰り返すことでカラーグループ判定値別 2次元配列を作成するのに必要は行数を求めることができます。

126行目で、119~123行目で計算したカラーグループ判定値別行数をカウントした変数 cntrgb を使って、112行目で動的配列として宣言した arrrgb を ReDim ステートメントで 2次元配列を作成します。この作成した 2次元配列 arrrgb に、130行目の For 文でカラーグループ判定値を格納している 2次元配列 data2 の行番号を格納します。


129行目でカウンタ変数 k を 0 で初期化します。このカウンタ変数 k は先ほど作成した 2次元配列 arrrgb の 1次元(行番号)を操作するのに使用します。

130行目の For 文でカラーグループ判定用値を格納した 2次元配列 data2 の 1次元の最大要素までループ処理します。なお、ここの For 文で使うカウンタ変数 i が行番号相当になって 134行目で使用します。

131行目の If 文で 2次元配列 data2 の i 行 1列目に格納したカラーグループ判定値 がカウンタ変数 p(114行目)と一致した場合、132行目でカウンタ変数 k をインクリメントして、134行目の 2次元配列 arrrgb の k 行 1 列目にカウンタ変数 i(行番号相当)を代入します。

上記の 130~136行目のループ処理でカラーグループ判定値が格納されている 2次元配列 data2 の行番号を、2次元配列 arrrgb に格納することができます。


2次元配列 arrrgb に格納したカラーグループ判定値別行番号に応じて、Interior.Color プロパティを使ったセル範囲のカラーグループ処理(複数色)をします。

139行目の For 文でカラーグループ判定値別行番号を格納した、2次元配列 arrrgb の 1次元最大要素までループ処理します。

141行目でワークシートを格納したオブジェクトの Range オブジェクトで指定したセル範囲に、Interior オブジェクトの Color プロパティに、RGB 関数の返り値を格納した 2次元配列 data2 の行番号に arrrgb(i, 1) を、列番号に 2 を指定して代入します。

このようにシート上でセル色を定義して 2次元配列に格納することで、カラーグループ別に変数や配列を別々に用意することはなく、シート上でカラーを増減してもコード内容を変更することなく、複数色に対応したセルへの色分け処理ができます。

Excel VBA コードメモリリーク対策について

X(Twitter) にて教えてもらいましたが、LBound と UBound 関数を使用した VBA コードの書き方によってはメモリリークが起きる可能性があるようです。

ただ、指摘のあった関数による VBA コードのメモリリークについて日本語で言及している情報が少なく、今回公開した VBA コードが原因でメモリリークが起きるかどうか確認できていません。(こちらで単純にメモリリークに気づいていないというのもあります)

X(Twitter) で紹介してもらった こちらのサイト ではメモリリークする・しないコードの書き方が紹介されています。以下各セクションではこの書き方にならって、コード内容を書き直したメモリリーク対策版 VBA コードを公開します。

メモリリークが起きないとされているコード内容に修正しただけなので、実際にメモリリークが起きないかどうかまでは確認していません。

基本的に関数の返り値を一度変数に格納して、その変数を使用する方法に書き換えた内容となっています。各コードについて元の VBA コードから追加・変更した箇所をハイライトで表示しています。

グループ別セル色分け(2色交互)処理 VBA サンプルコード 1 メモリリーク対策版

Option Explicit

Sub AlternatingColoringGroupsofRows1FixMemoryLeaks1() ' メモリリーク対策版
  ' 各行のグループごとにセル色を2色交互設定

  ' 実行速度計測開始
  Dim starttime As Double
  starttime = Timer

' ----------

  ' カウンタ用変数(一見見分けにくい文字同士を組み合わせない形、i と j、m と n、o(オー) と 0(ゼロ))
  Dim i As Long

' ----------

  ' シート格納用オブジェクト変数
  Dim ws1 As Worksheet

  ' オブジェクト変数にシートセット
  Set ws1 = ThisWorkbook.Worksheets("グループ別カラー1") ' セル色反映先シートをオブジェクト変数にセット

' ----------

  ' 最終行取得用変数
  Dim maxrow1 As Long

  ' シート最終行取得して変数に格納
  maxrow1 = ws1.Cells(Rows.Count, "A").End(xlUp).row

  ' 最終列取得用変数
  Dim maxcol1 As Long

  ' シートの最終列取得して変数に格納
  maxcol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column

  ' セル色をクリアして初期化
  ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, maxcol1)).Interior.ColorIndex = 0

' ----------

  ' シートの指定したセル範囲を配列として格納する動的配列
  Dim data1() As Variant, data2() As Variant

  ' シートの指定した範囲内セルを配列として動的配列に格納
  data1 = ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)).Value ' シート「グループ別カラー」のカラーグループ判定対象列(A 列)を含む、カラー化対象セルを配列 data1 に代入
  data2 = ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)).Value ' カラーグループ判定用値を格納するため配列 data2 を生成(ここでは D ~ E 列(maxcol1 + 1 ~ maxcol1 + 2)の空セルを指定)

  ' Range オブジェクトを受け取り、2次元配列で返す自作関数 GetArrFromRange
'  data1 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)))
'  data2 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)))

' ----------

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_data2_1D As Variant, UB_data2_1D As Variant
  LB_data2_1D = LBound(data2, 1)
  UB_data2_1D = UBound(data2, 1)

  ' 配列 data2 の先頭にカラーグループ判定の基準となる初期値(1)を代入
  data2(1, 1) = 1

  ' 初期値の次の値(配列)からスタートとして最終行までを for 文でループ処理(カラーグループ判定処理)
  For i = LB_data2_1D + 1 To UB_data2_1D ' 2行目から 1次元最大要素までループ処理

    ' ひとつ前の配列 data1(i - 1, 1) を data1(i, 1) と比較して一致した場合、ひとつ前の配列に代入した値を配列 data2(i, 1) に代入
    If data1(i - 1, 1) = data1(i, 1) Then
      data2(i, 1) = data2(i - 1, 1)
    ' ひとつ前の配列 data1(i - 1, 1) を data1(i, 1) と比較して一致しない場合、ひとつ前の配列に代入した値に -1 を乗算(1 → -1、-1 → 1 に変化)したものを配列 data2(i, 1) に代入
    ElseIf data1(i - 1, 1) <> data1(i, 1) Then
      data2(i, 1) = data2(i - 1, 1) * -1
    End If

  Next i

' ----------

  ' RGB 関数返り値格納用変数宣言
  Dim rgb1 As String, rgb2 As String
  
  ' RGB 関数にセル色を指定して変数に格納
  rgb1 = RGB(255, 150, 150)
  rgb2 = RGB(150, 255, 150)

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_data1_1D As Variant, UB_data1_1D As Variant
  LB_data1_1D = LBound(data1, 1)
  UB_data1_1D = UBound(data1, 1)

  ' 配列 data2(i, 2) にカラーグループ判定処理の値(1 or -1)に応じて変数 rgb1・rgb2 を代入(デバッグ用)
  For i = LB_data1_1D To UB_data1_1D
    If data2(i, 1) = 1 Then
      data2(i, 2) = rgb1
    ElseIf data2(i, 1) = -1 Then
      data2(i, 2) = rgb2
    End If
  Next i

  ' UBound 関数格納用変数と代入(メモリリーク対策)
  Dim UB_data2_2D As Variant
  UB_data2_2D = UBound(data2, 2)

  ' 配列 data2 に代入したカラーグループ判定用値と RGB 関数結果をシートの任意のセル D ~ E 列に転記(デバッグ用)
'  ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)).ClearContents
'  ws1.Range("D2").Resize(UB_data2_1D, UB_data2_2D).Value = data2

' ----------

  ' 地方区分別にセル色を設定
  ' 配列 data2(i, 1) のカラーグループ判定値(1 or -1)に応じて、該当セル範囲を Interior.Color プロパティで RGB 関数の値を格納した変数 rgb1・rgb2 を代入

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_data1_2D As Variant, UB_data1_2D As Variant
  LB_data1_2D = LBound(data1, 2)
  UB_data1_2D = UBound(data1, 2)

  ' 配列 data2(i,1) に格納したカラーグループ判定値(1 or -1)を参照してセル色を指定
  For i = LB_data1_1D To UB_data1_1D ' 1次元最大要素までループ処理
  
    ' セル色をつけたくない場合は If ~ End If までをコメントアウトするか削除
    If data2(i, 1) = 1 Then
      ws1.Range(ws1.Cells(i + 1, LB_data1_2D), ws1.Cells(i + 1, UB_data1_2D)).Interior.Color = rgb1
    End If
    
    ' セル色をつけたくない場合は If ~ End If までをコメントアウトするか削除
    If data2(i, 1) = -1 Then
      ws1.Range(ws1.Cells(i + 1, LB_data1_2D), ws1.Cells(i + 1, UB_data1_2D)).Interior.Color = rgb2
    End If

  Next i

' ----------

  ws1.Activate ' シートアクティブ

  ' 実行速度計測結果表示
  Debug.Print Format(Timer - starttime, "0.00秒")

End Sub

グループ別セル色分け(2色交互)処理 VBA サンプルコード 2 メモリリーク対策版

Option Explicit

Sub AlternatingColoringGroupsofRows2FixMemoryLeaks1() ' メモリリーク対策版
  ' 各行のグループごとにセル色を2色交互設定

  ' 実行速度計測開始
  Dim starttime As Double
  starttime = Timer

' ----------

  ' カウンタ用変数(一見見分けにくい文字同士を組み合わせない形、i と j、m と n、o(オー) と 0(ゼロ))
  Dim i As Long, k As Long

' ----------

  ' シート格納用オブジェクト変数
  Dim ws1 As Worksheet

  ' オブジェクト変数にシートセット
  Set ws1 = ThisWorkbook.Worksheets("グループ別カラー2") ' セル色反映先シートをオブジェクト変数にセット

' ----------

  ' 最終行取得用変数
  Dim maxrow1 As Long

  ' シート最終行取得して変数に格納
  maxrow1 = ws1.Cells(Rows.Count, "A").End(xlUp).row

  ' 最終列取得用変数
  Dim maxcol1 As Long

  ' シートの最終列取得して変数に格納
  maxcol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column

  ' セル色をクリアして初期化
  ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, maxcol1)).Interior.ColorIndex = 0

' ----------

  ' シートの指定したセル範囲を配列として格納する動的配列
  Dim data1() As Variant, data2() As Variant

  ' シートの指定した範囲内セルを配列として動的配列に格納
  data1 = ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)).Value ' シート「グループ別カラー」のカラーグループ判定対象列(A 列)を含む、カラー化対象セルを配列 data1 に代入
  data2 = ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)).Value ' カラーグループ判定用値を格納するため配列 data2 を生成(ここでは D ~ E 列(maxcol1 + 1 ~ maxcol1 + 2)の空セルを指定)

  ' Range オブジェクトを受け取り、2次元配列で返す自作関数 GetArrFromRange
'  data1 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)))
'  data2 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)))

' ----------

  ' 配列 data2 の先頭にカラーグループ判定の基準となる初期値(1)を代入
  data2(1, 1) = 1

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_data2_1D As Variant, UB_data2_1D As Variant
  LB_data2_1D = LBound(data2, 1)
  UB_data2_1D = UBound(data2, 1)

  ' 初期値の次の値(配列)からスタートとして最終行までを for 文でループ処理(カラーグループ判定処理)
  For i = LB_data2_1D + 1 To UB_data2_1D ' 2行目から 1次元最大要素までループ処理

    ' ひとつ前の配列 data1(i - 1, 1) を data1(i, 1) と比較して一致した場合、ひとつ前の配列に代入した値を配列 data2(i, 1) に代入
    If data1(i - 1, 1) = data1(i, 1) Then
      data2(i, 1) = data2(i - 1, 1)
    ' ひとつ前の配列 data1(i - 1, 1) を data1(i, 1) と比較して一致しない場合、ひとつ前の配列に代入した値に -1 を乗算(1 → -1、-1 → 1 に変化)したものを配列 data2(i, 1) に代入
    ElseIf data1(i - 1, 1) <> data1(i, 1) Then
      data2(i, 1) = data2(i - 1, 1) * -1
    End If

  Next i

' ----------

  ' RGB 関数返り値格納用変数宣言
  Dim rgb1 As String, rgb2 As String
  
  ' RGB 関数にセル色を指定して変数に格納
  rgb1 = RGB(255, 150, 150)
  rgb2 = RGB(150, 255, 150)

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_data1_1D As Variant, UB_data1_1D As Variant
  LB_data1_1D = LBound(data1, 1)
  UB_data1_1D = UBound(data1, 1)

  ' 配列 data2(i, 2) にカラーグループ判定処理の値(1 or -1)に応じて変数 rgb1・rgb2 を代入(デバッグ用)
  For i = LB_data1_1D To UB_data1_1D
    If data2(i, 1) = 1 Then
      data2(i, 2) = rgb1
    ElseIf data2(i, 1) = -1 Then
      data2(i, 2) = rgb2
    End If
  Next i

  ' UBound 関数格納用変数と代入(メモリリーク対策)
  Dim UB_data2_2D As Variant
  UB_data2_2D = UBound(data2, 2)

  ' 配列 data2 に代入したカラーグループ判定用値と RGB 関数結果をシートの任意のセル D ~ E 列に転記(デバッグ用)
'  ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)).ClearContents
'  ws1.Range("D2").Resize(UB_data2_1D, UB_data2_2D).Value = data2

' ----------

  ' カラーグループ判定値(1 or -1)別に行番号を取得、If 文を使わずに For 文のループ処理で行番号を格納した配列を使ってセル色設定

  ' カラーグループ判定値(1 or -1)カウント用配列宣言
  Dim cntrgb() As Variant

  ' カラーグループ判定値(1 or -1)を格納する動的配列を作成
  ReDim cntrgb(1) ' cntrgb(0) - カラーグループ判定処理の値(1)合計、cntrgb(1) - カラーグループ判定処理の値(-1)合計

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_cntrgb As Variant, UB_cntrgb As Variant
  LB_cntrgb = LBound(cntrgb)
  UB_cntrgb = UBound(cntrgb)

  For i = LB_cntrgb To UB_cntrgb
    cntrgb(i) = 0 ' 初期値 0 設定
  Next i

  ' Array 関数を使って配列の各要素に初期値 0 設定(動的配列(ReDim)や For 文を使わない)
'  cntrgb = Array(0, 0)

  ' If 文でカラーグループ判定値(1 or -1)を判定、カウントして配列 cntrgb に格納
  For i = LB_data1_1D To UB_data1_1D ' 1次元最大要素までループ処理
    If data2(i, 1) = 1 Then ' 配列 data2 の i 行 1列目がカラーグループ判定値 1 の場合
      cntrgb(0) = cntrgb(0) + 1 ' 配列 cntrgb(0) をインクリメント(+1)して配列  cntrgb(0) に格納
    End If

    If data2(i, 1) = -1 Then ' 配列 data2 の i 行 1列目がカラーグループ判定値 -1 の場合
      cntrgb(1) = cntrgb(1) + 1 ' 配列 cntrgb(1) をインクリメント(+1)して配列 cntrgb(1) に格納
    End If
  Next i

  Dim arrrgb1() As Variant ' カラーグループ判定値(1)がある行番号を配列として格納する動的配列宣言
  ReDim arrrgb1(1 To cntrgb(0), 1 To 1) ' 配列 arrrgb1 にカウントしたカラーグループ判定値(1)の個数を行数とする 2次元配列作成

  ' カラーグループ判定値(1)がある行番号を、配列 arrrgb1 に格納する処理
  k = 0 ' 配列 arrrgb1 用行番号変数の初期化
  For i = LB_data2_1D To UB_data2_1D ' 配列 data2 の 1次元最大要素までループ処理
    If data2(i, 1) = 1 Then ' 配列 data2 の i 行 1列目がカラーグループ判定値 1 の場合
      k = k + 1 ' 配列 arrrgb1 の行番号 k をインクリメント(+1)
      ' 配列 data2 の i 行目でカラーグループ判定値(1)が一致した時のループ処理変数 i(カラーグループ判定値(1)がある行番号相当)を配列 arrrgb1 の 行番号 k に代入
      arrrgb1(k, 1) = i
    End If
  Next i

  Dim arrrgb2() As Variant ' カラーグループ判定値(-1)がある行番号を配列として格納する動的配列宣言
  ReDim arrrgb2(1 To cntrgb(1), 1 To 1) ' 配列 arrrgb2 にカウントしたカラーグループ判定値(-1)の個数を行数とする 2次元配列作成

  ' カラーグループ判定値(-1)がある行番号を、配列 arrrgb2 に格納する処理
  k = 0 ' 配列 arrrgb2 用行番号変数の初期化
  For i = LB_data2_1D To UB_data2_1D ' 配列 data2 の 1次元最大要素までループ処理
    If data2(i, 1) = -1 Then ' 配列 data2 の i 行 1列目がカラーグループ判定値 -1 の場合
      k = k + 1 ' 配列 arrrgb2 の行番号 k をインクリメント(+1)
      ' 配列 data2 の i 行目でカラーグループ判定値(-1)が一致した時のループ処理変数 i(カラーグループ判定値(-1)がある行番号相当)を配列 arrrgb2 の 行番号 k に代入
      arrrgb2(k, 1) = i
    End If
  Next i

' ----------

  ' 地方区分別にセル色を設定

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_arrrgb1_1D As Variant, UB_arrrgb1_1D As Variant
  Dim LB_arrrgb2_1D As Variant, UB_arrrgb2_1D As Variant
  LB_arrrgb1_1D = LBound(arrrgb1, 1)
  UB_arrrgb1_1D = UBound(arrrgb1, 1)
  LB_arrrgb2_1D = LBound(arrrgb2, 1)
  UB_arrrgb2_1D = UBound(arrrgb2, 1)

  Dim LB_data1_2D As Variant, UB_data1_2D As Variant
  LB_data1_2D = LBound(data1, 2)
  UB_data1_2D = UBound(data1, 2)

  ' セル色をつけたくない場合は For ~ Next i までをコメントアウトするか削除
  For i = LB_arrrgb1_1D To UB_arrrgb1_1D ' 配列 arrrgb1 の 1次元最大要素までループ処理
    ' 配列 arrrgb1 に格納したカラーグループ判定値(1)がある行番号を、色設定するセルの行番号に指定(arrrgb1(i, 1) + 1)
    ws1.Range(ws1.Cells(arrrgb1(i, 1) + 1, LB_data1_2D), ws1.Cells(arrrgb1(i, 1) + 1, UB_data1_2D)).Interior.Color = rgb1
  Next i

  ' セル色をつけたくない場合は For ~ Next i までをコメントアウトするか削除
  For i = LB_arrrgb2_1D To UB_arrrgb2_1D ' 配列 arrrgb2 の 1次元最大要素までループ処理
    ' 配列 arrrgb2 に格納したカラーグループ判定値(-1)がある行番号を、色設定するセルの行番号に指定(arrrgb2(i, 1) + 1)
    ws1.Range(ws1.Cells(arrrgb2(i, 1) + 1, LB_data1_2D), ws1.Cells(arrrgb2(i, 1) + 1, UB_data1_2D)).Interior.Color = rgb2
  Next i

' ----------

  ws1.Activate ' シートアクティブ

  ' 実行速度計測結果表示
  Debug.Print Format(Timer - starttime, "0.00秒")
  
End Sub

グループ別セル色分け(3色以上)処理 VBA サンプルコード メモリリーク対策版

Option Explicit

Sub AlternatingColoringGroupsofRows3FixMemoryLeaks1() ' メモリリーク対策版
  ' 各行のグループごとにセル色を複数設定

  ' 実行速度計測開始
  Dim starttime As Double
  starttime = Timer

' ----------

  ' カウンタ用変数(一見見分けにくい文字同士を組み合わせない形、i と j、m と n、o(オー) と 0(ゼロ))
  Dim i As Long, k As Long, p As Long

' ----------

  ' シート格納用オブジェクト変数
  Dim ws1 As Worksheet, ws2 As Worksheet

  ' オブジェクト変数にシートセット
  Set ws1 = ThisWorkbook.Worksheets("グループ別カラー3") ' セル色反映先シートをオブジェクト変数にセット
  Set ws2 = ThisWorkbook.Worksheets("RGB値シート") ' RGB 関数用 RGB 値シートをオブジェクト変数にセット

' ----------

  ' 最終行取得用変数
  Dim maxrow1 As Long, maxrow2 As Long

  ' シート最終行取得して変数に格納
  maxrow1 = ws1.Cells(Rows.Count, "A").End(xlUp).row
  maxrow2 = ws2.Cells(Rows.Count, "A").End(xlUp).row

  ' 最終列取得用変数
  Dim maxcol1 As Long
  Dim maxcol2 As Long

  ' シートの最終列取得して変数に格納
  maxcol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
  maxcol2 = ws2.Cells(1, Columns.Count).End(xlToLeft).Column

  ' セル色をクリアして初期化
  ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, maxcol1)).Interior.ColorIndex = 0

' ----------

  ' シートの指定したセル範囲を配列として格納する動的配列
  Dim data1() As Variant, data2() As Variant, data3() As Variant

  ' シートの指定した範囲内セルを配列として動的配列に格納
  data1 = ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)).Value ' シート「グループ別カラー」のカラーグループ判定対象列(A 列)を含む、カラー化対象セルを配列 data1 に代入
  data2 = ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)).Value ' カラーグループ判定用値を格納するため配列 data2 を生成(ここでは D ~ E 列(maxcol1 + 1 ~ maxcol1 + 2)の空セルを指定)
  data3 = ws2.Range(ws2.Cells(2, 1), ws2.Cells(maxrow2, maxcol2 - 1)).Value ' シート「RGB値」の各セルにある RGB 値(0 ~ 255)を配列 data3 に代入(D 列(色見本)除外のため maxcol2 - 1 で C 列まで指定)

  ' Range オブジェクトを受け取り、2次元配列で返す自作関数 GetArrFromRange
'  data1 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)))
'  data2 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)))
'  data3 = GetArrFromRange.GetArrFromRange(ws2.Range(ws2.Cells(2, 1), ws2.Cells(maxrow2, maxcol2 - 1)))

' ----------

  ' 配列 data2 の先頭にカラーグループ判定の基準となる初期値(1)を代入
  data2(1, 1) = 1

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_data2_1D As Variant, UB_data2_1D As Variant
  LB_data2_1D = LBound(data2, 1)
  UB_data2_1D = UBound(data2, 1)

  ' 初期値の次の値(配列)からスタートとして最終行までを for 文でループ処理(カラーグループ判定処理)
  For i = LB_data2_1D + 1 To UB_data2_1D ' 2行目から 1次元最大要素までループ処理

    ' ひとつ前の配列 data1(i - 1, 1) を data1(i, 1) と比較して一致した場合、ひとつ前の配列に代入した値を配列 data2(i, 1) に代入
    If data1(i - 1, 1) = data1(i, 1) Then
      data2(i, 1) = data2(i - 1, 1)
    ' ひとつ前の配列 data1(i - 1, 1) を data1(i, 1) と比較して一致しない場合、ひとつ前の配列に代入した値にインクリメント(+1)したものを配列 data2(i, 1) に代入
    ElseIf data1(i - 1, 1) <> data1(i, 1) Then
      data2(i, 1) = data2(i - 1, 1) + 1
    End If

    ' data2(i, 1) に代入した値がシート「RGB値」に設定した色数(=行数(maxrow2 - 1))より多い場合、data2(i, 1) に 1 を代入
    ' 3色設定の場合、data2(i, 1) が 4 になったときに 1 を代入(カラーグループ判定値を 1 → 2 → 3 → 1 → 2 のようにループ処理)
    If data2(i, 1) > maxrow2 - 1 Then
      data2(i, 1) = 1
    End If

  Next i

' ----------
  
  ' RGB 関数に RGB 値をセットして配列 data(i, 2) に代入

  For i = LB_data2_1D To UB_data2_1D ' 1次元最大要素までループ処理

    ' 配列 data2(i, 1) のカラーグループ判定値(1 or 2 or 3)を変数 k に代入
    k = data2(i, 1)
    
    ' 配列 data2(i, 2) に RGB 値をセットした RGB 関数の結果を代入
    ' RGB 値は配列 data3 の行列を指定
    ' 配列 data3 の行には変数 k の値(カラーグループ判定値 1 or 2 or 3)で行指定
    ' 配列 data3 の列には 1・2・3 の値を順番に指定、それぞれの値は配列 data3 の 1 ~ 3 列に格納された RGB 値がある列
    data2(i, 2) = RGB(data3(k, 1), data3(k, 2), data3(k, 3))

  Next i

  ' UBound 関数格納用変数と代入(メモリリーク対策)
  Dim UB_data2_2D As Variant
  UB_data2_2D = UBound(data2, 2)

  ' 配列 data2 に代入したカラーグループ判定用値と RGB 関数結果をシートの任意のセル D ~ E 列に転記(デバッグ用)
'  ws1.Range(ws1.Cells(2, maxcol1 + 1), ws1.Cells(maxrow1, maxcol1 + 2)).ClearContents
'  ws1.Range("D2").Resize(UB_data2_1D, UB_data2_2D).Value = data2

' ----------

  ' カラーグループ判定値(1 or 2 or 3)別に行番号を取得、セル色設定には If 文による判定処理を使わずに For 文のループ処理で行番号を格納した配列を使用

  ' カラーグループ判定値(1 or 2 or 3)別カウント用変数宣言
  Dim cntrgb As Long
  
  ' カラーグループ判定値(1 or 2 or 3)がある行番号を配列として格納する動的配列宣言
  Dim arrrgb() As Variant

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_data1_1D As Variant, UB_data1_1D As Variant
  Dim LB_data1_2D As Variant, UB_data1_2D As Variant
  Dim LB_data3_1D As Variant, UB_data3_1D As Variant
  LB_data1_1D = LBound(data1, 1)
  UB_data1_1D = UBound(data1, 1)
  LB_data1_2D = LBound(data1, 2)
  UB_data1_2D = UBound(data1, 2)
  LB_data3_1D = LBound(data3, 1)
  UB_data3_1D = UBound(data3, 1)

  ' LBound・UBound 関数格納用変数(メモリリーク対策)
  Dim LB_arrrgb_1D As Variant, UB_arrrgb_1D As Variant

  For p = LB_data3_1D To UB_data3_1D ' 1次元最大要素までループ処理(色数分処理)

    cntrgb = 0 ' カラーグループ判定値(1 or 2 or 3)別カウント変数、初期値 0 設定

    ' If 文でカラーグループ判定値をカウントして合計を変数 cntrgb に格納
    For i = LB_data1_1D To UB_data1_1D ' 1次元最大要素までループ処理
      If data2(i, 1) = p Then ' 配列 data2 の i 行 1列目のカラーグループ判定値が、変数 p(1 or 2 or 3)と同じ場合
        cntrgb = cntrgb + 1 ' 変数 cntrgb をインクリメント(+1)して変数 cntrgb に格納
      End If
    Next i

    ' 配列 arrrgb にカウントしたカラーグループ判定値(1 or 2 or 3)の個数を行数とする 2次元動的配列作成
    ReDim arrrgb(1 To cntrgb, 1 To 1) ' カラーグループ判定値(1 or 2 or 3)別に動的配列を作成、変数 p を使った For 文の処理ごとに実行(同時に初期化)

    ' LBound・UBound 関数格納用変数へ代入(メモリリーク対策)
    LB_arrrgb_1D = LBound(arrrgb, 1)
    UB_arrrgb_1D = UBound(arrrgb, 1)

    ' カラーグループ判定値(1 or 2 or 3)がある行番号を、配列 arrrgb に格納する処理
    k = 0 ' 配列 arrrgb の行番号用として変数 k を 0 で初期化
    For i = LB_data2_1D To UB_data2_1D ' 配列 data2 の 1次元最大要素までループ処理
      If data2(i, 1) = p Then ' 配列 data2 の i 行 1列目のカラーグループ判定値が、変数 p(1 or 2 or 3)と同じ場合
        k = k + 1 ' 配列 arrrgb の行番号 k をインクリメント(+1)
        ' 配列 data2 の i 行 1列目でカラーグループ判定値(1 or 2 or 3)が一致した時のループ処理変数 i(カラーグループ判定値(1 or 2 or 3)がある行番号相当)を配列 arrrgb の 行番号 k に代入
        arrrgb(k, 1) = i
      End If
    Next i

    ' 地方区分別にセル色を設定
    For i = LB_arrrgb_1D To UB_arrrgb_1D ' 配列 arrrgb の 1次元最大要素までループ処理
      ' 配列 arrrgb に格納したカラーグループ判定値(1 or 2 or 3)がある行番号を、色設定するセルの行番号に指定(arrrgb(i, 1) + 1)
      ws1.Range(ws1.Cells(arrrgb(i, 1) + 1, LB_data1_2D), ws1.Cells(arrrgb(i, 1) + 1, UB_data1_2D)).Interior.Color = data2(arrrgb(i, 1), 2)
    Next i

  Next p

' ----------

  ws1.Activate ' シートアクティブ

  ' 実行速度計測結果表示
  Debug.Print Format(Timer - starttime, "0.00秒")
  
End Sub

RGB 値からセル色設定 VBA サンプルコード メモリリーク対策版

Option Explicit

Sub RGBColorFixMemoryLeaks1() ' メモリリーク対策版
  ' シート「RGB値」各セルに入力した RGB 値から RGB 関数でセルに色設定

  ' 実行速度計測開始
  Dim starttime As Double
  starttime = Timer

' ----------

  ' カウンタ用変数(一見見分けにくい文字同士を組み合わせない形、i と j、m と n、o(オー) と 0(ゼロ))
  Dim i As Long

' ----------

  ' シート格納用オブジェクト変数
  Dim ws1 As Worksheet

  ' オブジェクト変数にシートセット
  Set ws1 = ThisWorkbook.Worksheets("RGB値シート") ' シートをオブジェクト変数にセット

' ----------

  ' 最終行取得用変数
  Dim maxrow1 As Long

  ' シート最終行取得して変数に格納
  maxrow1 = ws1.Cells(Rows.Count, "A").End(xlUp).row

  ' 最終列取得用変数
  Dim maxcol1 As Long

  ' シートの最終列取得して変数に格納
  maxcol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column

' ----------

  ' D 列のセル色をクリアして初期化
  ws1.Range(ws1.Cells(2, maxcol1), ws1.Cells(maxrow1, maxcol1)).Interior.ColorIndex = 0

' ----------

  ' シートの指定したセル範囲を配列として格納する動的配列
  Dim data1() As Variant

  ' シートの指定した範囲内セルを配列として動的配列に格納
  data1 = ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, 3)).Value

' ----------

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_data1_1D As Variant, UB_data1_1D As Variant
  LB_data1_1D = LBound(data1, 1)
  UB_data1_1D = UBound(data1, 1)

  For i = LB_data1_1D To UB_data1_1D
    ws1.Cells(i + 1, maxcol1).Value = "Sample"
    ws1.Cells(i + 1, maxcol1).Interior.Color = RGB(data1(i, 1), data1(i, 2), data1(i, 3))
  Next i

' ----------

  ws1.Activate ' シートアクティブ

  ' 実行速度計測結果表示
  Debug.Print Format(Timer - starttime, "0.00秒")

End Sub