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




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


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

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

回答の条件
  • 1人1回まで
  • 13歳以上
  • 登録:2015/12/28 06:32:27
  • 終了:2015/12/29 08:53:57

ベストアンサー

id:a-kuma3 No.1

a-kuma3回答回数4325ベストアンサー獲得回数17732015/12/28 10:36:04

ポイント250pt

以下のコードを標準モジュールに貼り付けて、set_background_color サブルーチンを実行してください。
アクティブなシートを対象にして、背景色の設定を行います。

Const MAX_ROW = 10000   ' 処理対象の最大行数

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")

    ' K~M 列の背景色を読み取る
    For c = 11 To 13    ' K - M
        r = 1
        Do Until is_blank_cell(Cells(r, c))
            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
            DoEvents
            r = r + 1
            If r > MAX_ROW Then     ' 念のため
                Exit Do
            End If
        Loop
    Next

    ' A, C, E, G, I 列に背景色を設定する
    For c = 1 To 9 Step 2   ' A, C, E, G, I
        r = 1
        is_prev_blank = False
        Do Until is_prev_blank And is_blank_cell(Cells(r, c))
            v = Cells(r, c).Value
            If bgcolor_map.Exists(v) Then
                Cells(r, c).Interior.Color = bgcolor_map.Item(v)
            End If
            is_prev_blank = is_blank_cell(Cells(r, c))
            DoEvents
            r = r + 1
            If r > MAX_ROW Then     ' 念のため
                Exit Do
            End If
        Loop
    Next
End Sub

K、L、M 列の背景色を A、C、E、G、I 列に設定するように作ってあります。
質問では、「A、C、E、G、I、K、L、M 列に……」とありますが、K、L、M 列で値が重複した場合に妙な感じになると思うので。

行方向の終了条件には、無限ループが恐いので最大の行数も指定してあります。

・K,L,M列内には同じ数値が入る場合があります。その場合は処理した順に塗りつぶすこととし、エラーは出さないでください。

値が重複した場合には、先勝ちにしました。
後勝ちにしたければ、以下の部分を

            ' 重複した場合は、先勝ち
            If Not bgcolor_map.Exists(v) Then
                bgcolor_map.Add v, bgcolor
            End If

以下のコードに置き換えてください。

            ' 重複した場合は、後勝ち
            If bgcolor_map.Exists(v) Then
                bgcolor_map.Remove v
            End If
            bgcolor_map.Add v, bgcolor
id:naranara19

いつも完璧にご配慮いただき、大変感謝しております!本当にありがとうございます。

2015/12/29 08:53:32

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

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

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

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

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