[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『特定文字列セルの塗りつぶしマクロ』（COLOR）
よろしくお願い致します！
以下のように、特定の文字列が入ったセルを塗りつぶすマクロを組んでいますが、
特定の文字列の種類が増えてきた為に、
▲マクロ完了まで時間を要す。
▲特定文字列を追加する作業が大変。
という悩みがあります。
（以下のマクロ例で記載したよりも本来はもっと特定文字列が多いです。）
そこで、可能であれば、
●所要時間を短くしたい。
●特定文字列を直接マクロに入れるのではなく、
Sheet2など別シートに塗りつぶしたい文字列をリスト化し、
そこを読み組んでくるようなマクロにしたい。
を実現するマクロに改良することは可能でしょうか？
別シートにリスト化した場合、"E ??"や"F??-"のようなワイルドカードを利用した
表現は難しいでしょうか？
もし難しいようであれば、リスト化する際は、完全一致の文字列で入力することは可能です。
どうかご教示よろしくお願いいたします。
=============================
Sub color()
'色づけ
Sheets("Sheet1").Select
'範囲指定
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim col As Long
Dim tbl As Range
For Each tbl In Selection
Select Case True
Case tbl.Value Like "AAA"
col = 39 'ペールブルー
Case tbl.Value Like "BBB"
col = 39 'ペールブルー]
Case tbl.Value Like "CC*"
col = 37 'ペールブルー
Case tbl.Value Like "DD*"
col = 37 'ペールブルー
Case tbl.Value Like "E ??"
col = 37 'ペールブルー
Case tbl.Value Like "F??-"
col = 37 'ペールブルー
Case tbl.Value Like "??-"
col = 37 'ペールブルー
Case tbl.Value Like "?-"
col = 37 'ペールブルー
Case tbl.Value Like "GG?"
col = 37 'ペールブルー
Case Else
col = 0 'その他 無し
End Select
tbl.Interior.ColorIndex = col
Next tbl
Range("A1").Select
End Sub
=============================
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
これはわかりますが
▲マクロ完了まで時間を要す。
データ量にもよりますけど、そんなにかかりますかね？
正規表現を使えば、処理時間は短縮されると思いますが・・・
具体的に、何件ぐらいのデータで、どれぐらいの時間がかかっているんでしょう？
（β） 2015/01/25(日) 17:33
>●所要時間を短くしたい。 >●特定文字列を直接マクロに入れるのではなく、 >Sheet2など別シートに塗りつぶしたい文字列をリスト化し、 >そこを読み組んでくるようなマクロにしたい。
A B
1 AAA 39
2 BBB 37
3 CC* 5
4 DD? 6
あらかじめSheet2のA列に検索条件、B列にcolorindex値を入力してリスト化するとして 所要時間はこれでもマシになるかもしれません。
Sub sample()
Dim tbl, r, i As Long, ii As Long
tbl = Sheets(2).Range("A1").CurrentRegion.Value
r = Selection.Value
For i = 1 To UBound(tbl)
For ii = 1 To UBound(r)
If r(ii, 1) Like tbl(i, 1) Then
Selection.Rows(ii).Resize(, UBound(r)).Interior.ColorIndex = tbl(i, 2)
End If
Next ii
Next i
End Sub
（Jera） 2015/01/25(日) 18:11
すでにコメントしましたが、処理速度という意味では、そんなにわるくはないのでは？ ただ、条件指定を、ハードコードにしておくと、確かに、運用が面倒ですね。
そういう意味では、Jeraさんの提示コードのように、条件を外だしにしておけば楽ですね。 それと、（2010では、ほとんど効果は薄いようですが）処理の先頭で、Application.ScreenUpdating = False を入れておけば、ほんの気持ち程度、早くなるかも。
もし、正規表現になれておられるなら
Sheet2のA列にColorIndex、B,C,D,・・・に、その条件 これを下にColorIndexごとに、ずらっと登録しておけば以下のコードでも対応できるかと。
Sub Test()
Dim reg As Object
Dim c As Range
Dim v() As Variant
Dim x As Long
Dim i As Long
Dim tmp As Variant
Set reg = CreateObject("VBScript.RegExp")
'パターン配列の準備
With Sheets("Sheet2")
x = .Range("A" & Rows.Count).End(xlUp).Row
ReDim v(1 To x, 1 To 2)
For Each c In .Range("A1:A" & x)
i = i + 1
v(i, 1) = c.Value 'Color Index
tmp = .Range(c.Offset(, 1), .Cells(c.Row, Columns.Count).End(xlToLeft)).Value
tmp = WorksheetFunction.Transpose(WorksheetFunction.Transpose(tmp))
If IsArray(tmp) Then
v(i, 2) = Join(tmp, "|")
Else
v(i, 2) = tmp
End If
Next
End With
With Sheets("Sheet1")
.Columns(1).Interior.ColorIndex = xlNone
For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
For i = LBound(v, 1) To UBound(v, 1)
reg.Pattern = v(i, 2)
If reg.Test(c.Value) Then
c.Interior.ColorIndex = v(i, 1)
Exit For
End If
Next
Next
End With
End Sub
（β） 2015/01/25(日) 19:24
すぐにご返信ありがとうございます！
所要時間は、1分程度なんですが、途中（応答なし）になったりするので、
もっと他にいい記述方法があるのかなとご相談した次第です。
Jeraさん
リスト化の案、ありがとうございます！
早速やってみたのですが、「型が一致しません。」が出てしまいました…。。
おそらく私の理解が足りないだけかと思うのですが、、
初心者なもので、以下の点について再度ご教示お願い致します＞＜
Sub sample()
Dim tbl, r, i As Long, ii As Long
tbl = Sheets(2).Range("A1").CurrentRegion.Value
↑この部分は、「Sheets（"Sheet2"）」などシートの名前に変えてもいいでしょうか？
また、リスト化をSheet2のB3:D30の範囲にする場合は、（"A1")部分をどのように
変更すればいいでしょうか？
r = Selection.Value
For i = 1 To UBound(tbl)
For ii = 1 To UBound(r) ←この部分で「型が一致しません。」と出ます。
If r(ii, 1) Like tbl(i, 1) Then
Selection.Rows(ii).Resize(, UBound(r)).Interior.ColorIndex = tbl(i, 2)
End If
Next ii
Next i
End Sub
Sheet1の検索範囲はどの部分で指定しているのでしょうか？
検索範囲が例えば、Sheet1のA1:Z50をC2:Z100に変更する場合は、
どこを変更すればよろしいでしょうか？
お手数おかけいたしますが、よろしくお願い致します。
（COLOR） 2015/01/25(日) 21:07
Jeraさんあて、コメントから推測すると、検索すべきセルが2000〜3000程度、条件としては 20〜30程度だと思われますので、いくらなんでも、１分は、かかりすぎですねぇ。 最近、別の案件で 5万 x 5万 （25億）の処理を行いましたが、それでも 200秒（3〜4分）で 終わりましたから・・・・
いずれにしても、今後のことも考えると、私がアップした正規表現処理ではなく、Like 処理が いいようですね。
ところで、【←この部分で「型が一致しません。」と出ます】。
Jeraさんのコードは、実行前に、処理領域をマウスで選択しておいて始めることが前提になっています。 おそらく、マクロ実行時には、単一セルだけが選択されていたせいだと思われます。
（β） 2015/01/25(日) 22:22
ご丁寧にありがとうございます！
おっしゃる通りできれば、Like処理でやりたいです。
そして、処理領域をマウスで選択することが前提になっていたのですね…
全然わかりませんでした。。
実際にマウスで選択してやると塗りつぶされたのですが、
該当する単一セルではなく、行ごと塗りつぶされるようで＞＜
●マウスで選択するのではなく、
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
のように処理領域を指定したいです。
●塗りつぶしは行ごとではなく、該当する単一セルだけを塗りつぶしたいです。
●リスト化の表をJeraさんが例であげてくださってようにA1セルからではなく、
以下のようにB2セルから入力されているような場合は、適宜変更できるような記述にしたい。
A B C
1
2 AAA 39
3 BBB 37
4 CC* 5
5 DD? 6
上記を叶えることはできますでしょうか＞＜？
どうかよろしくお願い致します。
（COLOR） 2015/01/26(月) 00:45
・処理領域を指定したいです
r = Selection.Value の前に、
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
これをいれればいかがですか？
・B2セルから入力されているような場合は、適宜変更できるような記述にしたい
もし、このシートのリスト範囲以外が空白なら
tbl = Sheets("シート名").UsedRange.Value でいけますが、リスト範囲以外に何かしら値の入ったセルが
あるなら、ほかの手立てが必要です。
（β） 2015/01/26(月) 05:37
↑ あぁ、もしかして ・B2セルから入力されているような場合は、適宜変更できるような記述にしたい
これは、そうなったらコードを直してもいいということですか？
それなら、B2から始まる場合は
tbl = Sheets("シート名").Range("B2").CurrentRegion.Value
それから
・塗りつぶしは行ごとではなく、該当する単一セルだけを塗りつぶしたいです。
前のレスの手当てで１列のSelectionになりますから、今のままのJeraさんのコードでも 結果単一セルになりますよ。
（β） 2015/01/26(月) 05:59
>●マウスで選択するのではなく、
>Range("A1").Select
>Range(Selection, Selection.End(xlDown)).Select
>Range(Selection, Selection.End(xlToRight)).Select
>のように処理領域を指定したいです。
r = Selection.Value で塗りつぶす範囲を指定していますので、ここを変更します。
実際どのシートのどこに塗りつぶしたいデータがあるのか説明が無いので分かりませんが、 そのセルを一度マウスで選択して Ctrl + * を押してください。 選択された範囲がCurretregionの範囲ですので、それで良いなら
r = Sheets("Sheet1").Range("A1").Currentregion.Value
^^^^実際に塗りつぶすセルの一部
のような記述にすると可変に対応できます。 >●塗りつぶしは行ごとではなく、該当する単一セルだけを塗りつぶしたいです。 >●リスト化の表をJeraさんが例であげてくださってようにA1セルからではなく、 >以下のようにB2セルから入力されているような場合は、適宜変更できるような記述にしたい。
コードを以下の通り変更してください。
※Sheet1にはあくまで複数の入力がある事を想定してます。 1セルしか入力がない場合、リストの条件を満たしても何もされません。
Sub sample2()
Dim tbl, r, i As Long, x As Long, y As Long
tbl = Sheets("Sheet2").Range("B2").CurrentRegion.Value '条件リスト
r = Sheets("Sheet1").Range("A1").CurrentRegion.Value '対象セル範囲
If Not IsArray(r) Then Exit Sub
For i = 1 To UBound(tbl)
For x = 1 To UBound(r, 1)
For y = 1 To UBound(r, 2)
If r(x, y) Like tbl(i, 1) Then
Sheets("Sheet1").Cells(x, y).Interior.ColorIndex = tbl(i, 2)
End If
Next y
Next x
Next i
End Sub
（Jera） 2015/01/26(月) 14:28
ご親切に何度も助けて頂きありがとうございました！
コードの意味も理解でき、勉強になりました！
Jeraさん
わかりやすくコードを変更して頂き、本当にありがとうございました！
完璧に色づけすることが出来ました。感謝いたします。
（COLOR） 2015/01/28(水) 13:02
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.