| |
▼どぢょりん さん：
Sheet2 のシートレイアウトが分からないので、
とりあえず、 Sheet1を使って「商品〜仕入れ先」対応表を
つくり、Sheet3に対して仕入れ先の書いてあるセルに四角形を
描画するまでの一連の処理をコードにしてみました。
（使う商品は Sheet2にあるものだけなら、Sheet2を使ったほうが
効率よいのですが、まあ、200行程度ならそうちがわないでしょう。）
'------------------------ 標準モジュール
Option Explicit
Sub test1()
Dim dic As Object
Dim dic2 As Object
Dim c As Range
Dim i As Long
Set dic = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
With Worksheets(1)
For Each c In .Range("B1", .Cells(.Rows.Count, 2).End(xlUp))
dic(c.Value) = c.Offset(, 3).Value
Next
End With
With Worksheets(3)
For Each c In .Range("E1").Resize(2, 2)
If Len(c.Value) > 0 Then
i = i + 1
dic2(c.Value) = i
End If
Next
.Rectangles.Delete
For Each c In .Range("B1", .Cells(.Rows.Count, 2).End(xlUp))
If Len(c.Value) > 0 Then
If dic.Exists(c.Value) Then
ss = dic(c.Value) '仕入れ先名
If dic2.Exists(ss) Then
i = dic2(ss)
Else
i = dic2.Count
End If
drawCircle c.Offset(, 3).Resize(2, 2).Item(i)
End If
End If
Next
End With
Set dic = Nothing
Set dic2 = Nothing
End Sub
【解説】
初めにこのプログラム（test1プロシージャ）内で使用する
変数を宣言します。
Dim dic As Object
Dim dic2 As Object
Dim c As Range
Dim i As Long
つぎに、宣言した2つのオブジェクト dic, dic2 を実体化します。
（2つのDictionaryオブジェクトを使えるようにします）
> Set dic = CreateObject("Scripting.Dictionary")
> Set dic2 = CreateObject("Scripting.Dictionary")
シート1のほうをみて、
「商品」と1対1に対応する「仕入れ先」をDictionaryに
順に格納していきます。
ワークシート1の[B1]セルから順に下方に、
> With Worksheets(1)
> For Each c In .Range("B1", .Cells(.Rows.Count, 2).End(xlUp))
> dic(c.Value) = c.Offset(, 3).Value
> Next
> End With
> dic(c.Value) = c.Offset(, 3).Value
の部分は ご提示の最初のデータでいえば、
dic("商品Ａ") = "Ａ社"
という処理をしていることになります。
B列を最後まで処理すると、dic 内には
key Item
---------------
商品Ａ Ａ社
商品Ｂ Ｂ社
商品Ｃ Ｃ社
商品Ｄ Ｄ社
というLOOKUPテーブルができていることになります。
これで、LOOKUPテーブルのほうはできましたので、
つぎに シート3 に行って、B列の「商品」に対応する「仕入れ先」
をE,F列の2行の範囲から検索し、該当するセルの上にマルを描く
処理に入ります。
まず、Ｅ列 Ｆ列 の仕入れ先名はどの2行も同じアイテムなので
先頭の「仕入れ先候補」範囲 [E1:F2] すなわち [E1].Resize(2, 2)
の範囲より、仕入れ先候補名とそのセル位置を 先ほどと同様
dic2にセットすることにします。
> With Worksheets(3)
> For Each c In .Range("E1").Resize(2, 2)
> If Len(c.Value) > 0 Then
> i = i + 1
> dic2(c.Value) = i
> End If
> Next
>sheet3
> Ａ列 Ｂ列 Ｃ列 Ｄ列 Ｅ列 Ｆ列
>＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿
>１ 11111-111 商品Ａ 10,000 5 Ａ社 Ｂ社
>２ Ｃ社 その他
> With Worksheets(3)
> For Each c In .Range("E1").Resize(2, 2)
と書いているので、For Each c のLoopは
[E1]→[F1]→[E2]→[F2]
とLoopします。このとき、この4つのセルには下図の右側のような
位置番号が振られます。
[E1] [F1] [1] [2]
[E2] [F2] [3] [4]
dic2には 「仕入れ先」に対応するセル位置番号をセットしています。
この結果、dic2というもう一つのLOOKUP TABLEは
（今回の例では）以下のようになります。
key Item
-----------
Ａ社 1
Ｂ社 2
Ｃ社 3
その他 4
> .Rectangles.Delete
これは、シート内のすべての四角形を削除しているところです。
(注) 今回は「角丸目四角形」を使いましたが、楕円で囲む場合は
.Obals.Delete
としてください。
さて、以上で準備ができましたので、ここから
B列の商品をみて dic（「商品-仕入先」対応表）より対応する仕入れ先を
取得し、
dic2（「仕入れ先-セル位置番号」対応表）に取得してあるセル位置に
図形を描いていく処理をします。
[B1]から最終データまで順に下方に調べていきます。
> For Each c In .Range("B1", .Cells(.Rows.Count, 2).End(xlUp))
ただし、B列セルに値の入っている行だけ処理をします。
> If Len(c.Value) > 0 Then
商品名がdicのkeyにあるか？以下で問い合わせます。
対応表は dicというメモリ内にあり、あるかないかは
dicのkey(商品名)を順に調べなくても↓で分かります。
> If dic.Exists(c.Value) Then
たとえばB列が「商品Ａ」ならその「仕入先名」はＡ社、
変数ss にこの「Ａ社」を代入します。
> ss = dic(c.Value) '仕入れ先名
「Ａ社」はE,F列のどの位置に書かれているか？
それは dic2に書いてありますので、その値を変数iに
代入します。ただし、「商品Ｄ」の仕入れ先「Ｄ社」は
dic2の対応表に書いてありませんので、そのときは(Else)
変数iに dic2.Countを代入します。今回は dic2.Countは
4です（4番目のセルという意味）
> If dic2.Exists(ss) Then
> i = dic2(ss)
> Else
> i = dic2.Count
> End If
こうして、いま注目している行のE,F列のどのセル位置に
図を描けばいいか？が分かりましたので、このセルを指定
して、図を描くサブ・プロシージャをCallします。
> drawCircle c.Offset(, 3).Resize(2, 2).Item(i)
> End If
> End If
> Next
> End With
さいごに、使用オブジェクトの利用が終わったことをオブジェクトに
通知してやります（この通知はプロシージャがEndするとき暗黙のうちに
されますから、ま、絶対必要ということはないですが）
> Set dic = Nothing
> Set dic2 = Nothing
>Private Sub drawCircle(c As Range)
のほうは、こちらが「丸い角の四角形」を描く操作のマクロ記録を
編集して作ったものです。そちらの描きたい図形にあわせて、適宜
変更してください。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
