1451605972 【再度】【エクセル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までは列内の色は様々なものとします。
・該当しない場合は何もしません。

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

回答の条件
  • 1人1回まで
  • 13歳以上
  • 登録:2016/01/01 08:52:52
  • 終了:2016/01/01 18:44:16

ベストアンサー

id:a-kuma3 No.1

a-kuma3回答回数4325ベストアンサー獲得回数17732016/01/01 17:30:00

ポイント300pt

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

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行出てくるまで続ける、というふうにしています。

id:naranara19

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

2016/01/01 18:43:46

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません