人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

【再度】【エクセルVBA】セル内の色を読み取って同じ数値のところに同じ色を塗りつけたい。


http://q.hatena.ne.jp/1451251947
にて質問したものですが、
ちょっと仕様を逆にしたいのです。


詳しくは画像をご確認ください。
A,C,E,G,I列にある数値や英文字の並びを読み取り、K,L,M列内の同数値に同じ色を塗りつけるマクロをお願いします。


【注意点】
・エクセルは条件付き書式の使えないバージョンでもできるマクロとします。(1997-2003)
・A,C,E,G,I,K,L,M列にはいる数値、英文字は3行までではなく、もっと続きます(最大行は1000行まででお願いします)
・K,L,M列内には同じ数値が入る場合があります。その場合は処理した順(先勝ち)に塗りつぶすこととし、エラーは出さないでください。
・どの列でも、列は、空白が★20行続いた時点で読み取りを終了します。(A,C,E,G,I,K,L,M列)
・K-Lまでは列内の色は様々なものとします。
・該当しない場合は何もしません。

恐れ入りますが、マクロ以外のご回答にポイントはおつけできません。
よろしくお願いいたします。

1451605972
●拡大する

●質問者: naranara19
●カテゴリ:コンピュータ
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● a-kuma3
●300ポイント ベストアンサー

こんな感じでどうでしょう。

Const MAX_ROW = 1000

Function is_blank_cell(c)
 is_blank_cell = IsEmpty(c) Or c.value = ""
End Function

Sub set_background_color()
 Dim bgcolor_map
 Set bgcolor_map = CreateObject("Scripting.Dictionary")

  ' A, C, E, G, I 列の背景色を読み取る
 For c = 1 To 9 Step 2  ' A, C, E, G, I
 r = 1
 blank_count = 0
 Do Until blank_count = 20  ' 空白行が20行続いたら打ち切り
 If is_blank_cell(Cells(r, c)) Then
 blank_count = blank_count + 1
 Else
 v = Cells(r, c).value
 bgcolor = Cells(r, c).Interior.Color
 If Not bgcolor_map.Exists(v) Then
 bgcolor_map.Add v, bgcolor
 End If
 blank_count = 0
 End If
 DoEvents
 r = r + 1
 If r > MAX_ROW Then  ' 念のため
 Exit Do
 End If
 Loop
 Next

  ' K?M 列に背景色を設定する
 For c = 11 To 13  ' K - M
 r = 1
 blank_count = 0
 Do Until blank_count = 20  ' 空白行が20行続いたら打ち切り
 v = Cells(r, c).value
 If bgcolor_map.Exists(v) Then
 Cells(r, c).Interior.Color = bgcolor_map.Item(v)
 End If
 If is_blank_cell(Cells(r, c)) Then
 blank_count = blank_count + 1
 Else
 blank_count = 0
 End If
 DoEvents
 r = r + 1
 If r > MAX_ROW Then  ' 念のため
 Exit Do
 End If
 Loop
 Next
End Sub

K?M 列の方は空白が20行出てくるまで、とするまでもないような気もするのですが、質問通り空白が20行出てくるまで続ける、というふうにしています。


naranara19さんのコメント
ものすごく速くて助かりました!!!20行というところも、こちらで調整しやすいように説明してくださっていて、本当にすごい方です。今年もよろしくお願いいたします。小額ですがプラスさせていただきます。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ