Excelのマクロでの色の取得とループ方法

質問

はじめまして。
マクロ初心者です。

Excelのセルを使って地方別の日本地図を作成しています。
イメージとしてはこれのExcel版といった感じです。
http://hp-sozai.net/tm-map/nt03.html

やりたいことは、別表の数字によってこの地方を色分けするマクロの作成です。
現在抱えている問題は、1.色の設定方法の改善、2.条件の設定方法の改善、3.現在のマクロの記述方法をシンプルにできないか、の3点です。

マクロは現在下記のように記述しています。
Sub 地方()

Hokkaido = Range("T4").Value

Select Case Hokkaido
Case ""
Range("P4").Interior.Color = QBColor(15)
Case 1 To 4999
Range("P4").Interior.Color = QBColor(11)
Case 5000 To 9999
Range("P4").Interior.Color = QBColor(9)
Case 10000 To 14999
Range("P4").Interior.Color = QBColor(2)
Case 15000 To 19999
Range("P4").Interior.Color = QBColor(10)
Case 20000 To 24999
Range("P4").Interior.Color = QBColor(14)
Case 25000 To 29999
Range("P4").Interior.Color = QBColor(13)
Case 30000 To 34999
Range("P4").Interior.Color = QBColor(12)

End Select

Tohoku = Range("T5").Value

Select Case Tohoku
Case 1 To 4999
Range("O8,O9,P7:P10").Interior.Color = QBColor(11)
Case 5000 To 9999
Range("P4").Interior.Color = QBColor(9)
Case 10000 To 14999
Range("P4").Interior.Color = QBColor(2)
Case 15000 To 19999
Range("P4").Interior.Color = QBColor(10)
Case 20000 To 24999
Range("P4").Interior.Color = QBColor(14)
Case 25000 To 29999
Range("P4").Interior.Color = QBColor(13)
Case 30000 To 34999
Range("P4").Interior.Color = QBColor(12)

End Select
・
・
・
（こを全地方分）

End Sub

1.色の設定方法の改善と2.条件の設定方法の改善について：
現在それぞれの地方ごとにセルA1:B7に凡例を作成しています。
凡例はセルAにフォントの色指定で着色した■、
セルBに0以上5000未満などの条件を入力してあります。
例：
A　　B
■　1以上5000未満
色は上記の通りマクロで直接指定していて、この■の色を変更してもマクロの色は変わりません。
これをリンクさせて、■の色が変更されたらマクロにも反映されるようにしたいと思っています。
条件についても同様で、Bの値が変わったらマクロの値も変わるように設定できたらいいのですが。。

3.現在のマクロの記述方法をシンプルにできないか、について：
見ての通り、今のマクロは同じ事を地方ごとに記述していて非常に長いものになっています。
これをもう少しシンプルに記述できないかと思っているのですが、
セルの範囲も地方によってさまざまなので上手いループが思いつかず行き詰まっています。

是非アイディアをいただけるとありがたいです。
どうぞよろしくお願いいたします。

回答No.2

pkh4989 · ベストアンサー

回答が遅くなりまして、すみません。

>このリストの場合、北海道の数値はどのセルに入れることになりますか？
→ E列になります。
>その数値が5000未満の場合は北海道が赤になる、といった具合で動作の予定です。
セル「E2」でRange「T4」を設定すればいいです。

A　　　　B　　　　　C　　　　　　D　　　　E　　　　F　　　G　　　H　　　I　　　J
カラー　範囲(FROM)　範囲(TO)　　東北　　　北海道　関東　　信越　北陸　　東海　近畿
　　　　　　　　　　　　　　　　O8,O9,P7:P10
赤　　　　　1　　　　4999　　　　P4　　　　T4 ← セル「E2」 Range「T4」を設定
黄　　　　　5000　　 9999　　　　Q5　　　　S5 ← 数値が5000～5999 で黄色の場合はこのセルにRange「例えばRangeがS5なら」を設定します
青　　　　　10000　　14999　　　S6
　　　　　　20000　　24999　　　P8
　　　　　　25000　　29999　　　Q6
　　　　　　30000　　34999　　　S8

お礼

お礼が遅くなり大変申し訳ございませんでした。
ご丁寧にありがとうございます！
アドバイスいただいた方法と、新しく思いついて色をつける部分はポリゴンで書く方法を組み合わせて試してみようと思います。

どうもありがとうございました。
助かりました。

回答No.1

pkh4989

こんにちは。

以下の方法では、如何でしょうか。
ActiveSheetには以下のように条件を設定します。
Aカラムは色を設定、B～Cカラムには範囲を、D～地方名を設定
セルD2～には各地方別に色を設定するRangeを設定します。
セル「D2」のように複数セルを指定する場合は Range("O8,O9,P7:P10")と同様に「O8,O9,P7:P10」設定します。

地図のSheet名を「地図」にします。

A　　　　B　　　　　C　　　　　　D　　　　E　　　　F　　　G　　　H　　　I　　　J
カラー　範囲(FROM)　範囲(TO)　　東北　　　北海道　関東　　信越　北陸　　東海　近畿
　　　　　　　　　　　　　　　　O8,O9,P7:P10
　　　　　　1　　　　4999　　　　P4
　　　　　　5000　　 9999　　　　Q5　　　P4
　　　　　　10000　　14999　　　S6
　　　　　　20000　　24999　　　P8
　　　　　　25000　　29999　　　Q6
　　　　　　30000　　34999　　　S8

Sub 日本地図色設定()
　　Dim mR　　　　　　As Long
　　Dim mC　　　　　　As Integer
　　Dim c　　　　　　 As Range
　　'
　　Sheets("地図").Cells.Interior.ColorIndex = xlNone　　　　　　 '色クリア

　　With ActiveSheet
　　　　mR = .Range("B" & Rows.Count).End(xlUp).Row　　　　　　　 '最大行設定
　　　　mC = .Range("A1").End(xlToRight).Column　　　　　　　　　 '最大カラム設定
　　　　For Each c In .Range(.Cells(2, "D"), .Cells(mC, mR))
　　　　　　If c.Value <> "" Then
　　　　　　　　'色設定
　　　　　　　　Sheets("地図").Range(c.Value).Interior.ColorIndex = .Range("A" & c.Row).Interior.ColorIndex
　　　　　　End If
　　　　Next
　　End With
End Sub

あくまでも、参考用ですので、変更して使ってください。

お礼

pkh4989さん、

早速のアドバイスありがとうございます！
現在ActiveSheetの部分から作成しているのですが、
このリストの場合、北海道の数値はどのセルに入れることになりますか？
その数値が5000未満の場合は北海道が赤になる、といった具合で動作の予定です。

アドバイスいただいたリストは以下の感じになるのかと予想しておりますが。。
A｜B｜C｜D｜E 　　　
赤｜0｜4999｜北海道｜東北
黄｜5000｜9999｜T4｜O8,O9,P7:P10
青｜10000｜14999｜数値？｜数値？

VBA以前の質問ですみませんm(__)m