エクセル VBA リストを参照して 色を変えたい

Sheet1に　リストとして
　　　　　　A 　　　B 　　　C　　　　D

--+-------+-------+-------+-------+------+-------+-------
1　　山田
--+-------+-------+-------+-------+------+-------+-------
2　　鈴木
--+-------+-------+-------+-------+------+-------+-------
3　　佐藤
--+-------+-------+-------+-------+------+-------+-------
4　　内藤

Sheet2に　一覧表として

　　　　　　A 　　　B 　 　　C　　　　D
--+-------+-------+-------+-------+------+-------+-------
1　　山田　　　赤松　　　斎藤　　　内藤
--+-------+-------+-------+-------+------+-------+-------
2　　佐藤　　　清水　　　鈴木　　　米田
--+-------+-------+-------+-------+------+-------+-------
3　　上田　　　今川　　　藤本　　　越崎
--+-------+-------+-------+-------+------+-------+-------
4　　千葉　　　尾崎　　　松田　　　安西

と、作成した場合、Sheet1のリストにある名前のみ
フォントカラーを赤にするマクロを組んでいただきたいのですが・・・
宜しくお願いします。

No.3 ベストアンサー 回答者： imogasi 回答日時： 2004/09/14 06:48

短いのを１つ。

Sub test01()
Dim sh1, sh2 As Worksheet
Dim cl As Range
Set sh1 = Worksheets("sheet1")
Set sh2 = Worksheets("sheet2")
d = sh1.Range("A1").CurrentRegion.Rows.Count
For Each cl In sh2.Range("A1").CurrentRegion
For j = 1 To d
If sh1.Cells(j, "A") = cl Then
cl.Interior.ColorIndex = 6
End If
Next j
Next
End Sub
丸投げ的な質問だが、ＳｅｔやＦｏｒＥａｃｈ、ＣｕｒｒｅｎｔＲｅｇｉｏｎなど及び本番データでどこをどう修正するか判りますでしょうか。

この回答へのお礼

回答有難うございます。
修正の仕方はわかります。
やりたかったことが目の前で展開されていきました。

丸投げを心より、反省し、それでも答えて下さった皆様に、感謝の気持ちでいっぱいです。
本当に、本当に有難うございました。<m(__)m>

お礼日時：2004/09/14 09:06

No.2 回答者： RECARO 回答日時： 2004/09/14 01:29

確かに丸投げはあんまり良くありませんね。

ちょっと考えてこんな風に書いてみたけどどうですか？というくらいの方が答えが返って来易いと思いますよ。


僕もあまり上手いコードは書けませんが，それなりに動くものを作ってみました。きっともっと効率の良い方法があると思いますが・・・

このコードでは，Sheet2のマトリックスの行，列方向の各最大値を計算するのが面倒だったので（歯抜け等を考え出すときりがないので），1個ずつセルをずらしてセルが空白になるまでリストとの比較をしています。よって，最大値の行列が真四角に全部埋まってないと正常に動きません。
リストの長さ判定と同じように行列の各最大値を求めてFOR文で回しても同じ結果になりますが・・・先に思いついた方でやっちゃいました。眠いのでここまでとします(笑)。

あと，このOKWEBのフォームの仕様上，コードのインデントが全部解除されて見難いですがご勘弁を。


Option Explicit
Option Base 1

Sub 名前検索()

Dim strNameList() As String 'Sheet1のリスト格納用配列
Dim intListLength As Integer 'Sheet1のリストの長さ
Dim i As Integer 'ループ用
Dim strCheckValue As String 'リストと比較されるSheet2のセル内の文字

Sheets("Sheet1").Activate

'Sheet1のリスと最終行の行数（＝リストの長さ）を調べる
intListLength = Cells(1, 1).End(xlDown).Row

ReDim strNameList(intListLength) 'リスト格納用配列の再宣言

'リストの全名前を配列に格納
For i = 1 To intListLength
strNameList(i) = Cells(i, 1).Value
Next i

Sheets("Sheet2").Activate

'アクティブなセルをセル"A1"から右に1つずらしながら
'セルが空白になるまで調査し，リストと一致したらフォントを
'赤に変える。
'右端のセルまで調査したら（空白になったら）1行下の左端へ
'ずらして繰り返し。下方向へもセルが空白になるまで繰り返し。
Cells(1, 1).Activate
strCheckValue = Cells(1, 1).Value
Do Until ActiveCell.Value = ""
Do Until ActiveCell.Value = ""
strCheckValue = ActiveCell.Value
For i = 1 To intListLength
If strCheckValue = strNameList(i) Then
ActiveCell.Font.ColorIndex = 3
Exit For
End If
Next i
ActiveCell.Offset(0, 1).Activate
Loop
Cells(ActiveCell.Row + 1, 1).Activate
Loop

End Sub

この回答へのお礼

丸投げ、反省しております。<m(__)m>
眠い中、回答頂き有難うございました。
感謝しております。
それぞれ、大変丁寧に記述して頂き、勉強になりました。
今後は質問の書き方も勉強していきます。

お礼日時：2004/09/14 09:01

No.1 回答者： papayuka 回答日時： 2004/09/14 00:31

丸投げは如何なモンでしょう？

条件付き書式で出来ますよ。

Sheet1のA列全部に名前を付ける（例）List
Sheet2の範囲を全て選択し、A1がアクティブな状態で条件付き書式の数式が

=NOT(ISERROR(VLOOKUP(A1,List,1,0)))

この回答へのお礼

丸投げ、申し訳ありません。<m(__)m>
条件付書式３つは全て使い果たしてしまいまして、
あれこれ試して、時間も無くなり、お願いしてしまいました。
言葉不足をお詫びします。

お礼日時：2004/09/14 08:45