Excel97で全シート検索のマクロを記述するには

質問

住所録みたいな物である文字を全シートから半角,全角,大文字,小文字を区別する事なく曖昧検索し検索されたセルが有る一行に色を塗りつぶし、又次を検索したら一行に色を塗りつぶすようにするマクロを作成するにはどのようにしたらよいでしょうか？
もし色を塗り潰すのが大変な場合は検索されたセルが有る行を選択する事によって色が変わり検索結果がわかりやすくなるマクロを作成するにはどのようにしたらよいでしょうか？
以下マクロを教えていただき実行したのですが、ちゃんと色が付く時と、ダメな時「実行時エラー'1004':　InteriorクラスのColorIndexプロパティを設定できません」とメッセージが出る時が有ります。
検索対象は各シート10～12列、全30シート計3500行くらいになります。
自分のPCはWinXP,CPU:3.06GHｚ,メモリ:1GHzですが
いろいろな機種みんなで使用したくCPU:1GHｚ,メモリ:256MBくらいでも使用出来たらと思います。宜しく御願いします。

Sub 検索color()
s = InputBox("検索文字列＝")
If s = "" Then
Exit Sub
End If

Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
Set x = sh.Cells.Find(what:=s, MatchByte:=False)
If x Is Nothing Then GoTo p1
b = sh.Name & x.Address
sh.Activate
x.Activate

Rows(x.Row).Select
Selection.Interior.ColorIndex = 36
x.Select

'---

Do
Set y = sh.Cells.FindNext(after:=ActiveCell)
If y Is Nothing Then GoTo p1
If sh.Name & y.Address = b Then GoTo p1

y.Activate

Rows(y.Row).Select
Selection.Interior.ColorIndex = 36
y.Select

Loop
p1:
Next
End Sub

回答No.2

Nayuta_X · ベストアンサー

仕事が、忙しくなってきましたので、回答が遅れてしまいました。

プログラムの修正は、まだ、途中ですが
希望あれば、言ってください。
プログラムを完成させたいので、完成するまで、締切にしないでくだいい。

Sub 検索color()

Dim sh As Worksheet
Dim flt As AutoFilter

S = InputBox("検索文字列＝")
If S = "" Then
Exit Sub
End If

sh_Name = ""

For Each sh In ActiveWorkbook.Worksheets

ActiveSheet.UsedRange.Select
hx = ActiveWindow.RangeSelection.EntireColumn.Count
Vy = ActiveWindow.RangeSelection.EntireRow.Count
Range("A1").Select

Set x = sh.Cells.Find(what:=S, MatchByte:=False)

If x Is Nothing Then GoTo p1

b = sh.Name & x.Address
If sh.Name <> sh_Name Then

sh_Name = sh.Name
sh.Activate

Columns("A:A").Offset(0, hx + 2).Select
Selection.ClearContents
For j = 1 To Vy
Range("A1").Offset(j - 1, hx + 2) = 0
Next j

Range("A1").Select
End If

sh.Activate
x.Activate

Rows(x.Row).Select
Range("A1").Offset(x.Row - 1, hx + 2) = 1
x.Select
Selection.Interior.ColorIndex = 36

Do
Set y = sh.Cells.FindNext(after:=ActiveCell)

If y Is Nothing Then Exit Do

If sh.Name & y.Address = b Then Exit Do

Rows(y.Row).Select
Range("A1").Offset(y.Row - 1, hx + 2) = 1
Rows(y.Row).Select
y.Activate
y.Select
Selection.Interior.ColorIndex = 36
Loop

Range("A1:B1").Offset(0, hx + 2).Select

Set flt = ActiveSheet.AutoFilter

If flt Is Nothing Then
Selection.AutoFilter
End If

Selection.AutoFilter Field:=1, Criteria1:="1"
Range("A1").Select

p1:
Next
End Sub

Sub 初期に戻す()

Dim sh As Worksheet
Dim flt As AutoFilter

sh_Name = ""

For Each sh In ActiveWorkbook.Worksheets

Set flt = ActiveSheet.AutoFilter

If flt Is Nothing Then
'　何もしない
Else
' AutoFilter を解除する
Selection.AutoFilter
End If

ActiveSheet.UsedRange.Select
hx = ActiveWindow.RangeSelection.EntireColumn.Count
Vy = ActiveWindow.RangeSelection.EntireRow.Count
Range("A1").Select

Cells.Select
Selection.Interior.ColorIndex = xlNone
Range("A1").Select

If sh.Name <> sh_Name Then
sh_Name = sh.Name
sh.Activate

Columns("A:A").Offset(0, hx - 1).Select
Selection.ClearContents
Range("A1").Select
End If

sh.Activate

Next

End Sub

お礼

書き込み有難う御座いました。
記述いただきましたマクロ試させていただいたのですが
大文字小文字区別なく検索したいのですがうまく検索できず
検索結果の前の行以前が非表示になってしまいます。
宜しく御願いします。

回答No.8

Nayuta_X

補足説明です。

Application.ScreenUpdating = False
Application.ScreenUpdating = True
　上(2行)をコメント行にすると　目まぐるしく　シートが、選択され　最後のシートが、開きぱなしになります。

Application.ScreenUpdating = False
上のコードは、マクロの処理を見せない為の　コードです。
Application.ScreenUpdating = True
上のコードは、マクロの処理を見せない為の　コードを解除するコードです。
上記2個は、マクロの高速化を図るためのコードです。

Sheets(Ops).Select
は、最後に　開いていたシートに戻す　コードです。
必要なければ、ここも　コメント行にします。

回答No.7

Nayuta_X

1.着色されるのですが検索されたシートへ飛びません。元のシート画面のままです。
2.上書き保存しないで閉じても、次回開くと前回の検索結果で着色されたままで保存されてしまいます。

回答です。
1.に関しては、たとえば、検索結果該当するものが、複数のシートであったら　あなたは、どうしたいのですか?。
最初のシートで、検索を中止して終われば、良いのでしょうか?。
あなたは、どのように考えているかは、分かりません。少なからずあなたは、VBAをご存じなのだから　何も、かにも、やってもらえると思わず、ご自分で　考えてください。
そもそも、全30シートもあるなんで、メモリーの無駄使いです。
だから、探しにくいのです。そして、エクセルの仕様の問題でエラーになるのですよ。ここらへんは、あなたも。自覚しているのでは、??。
3500行くらいなら、1シートに、すべて　書き込みが、出来ます。
また、検索結果は、先のオートフィルタを使用すれば、簡単に分かります。　あなたは、それを拒否しましたがね。(笑)
2.に関しては、そのような処理(上書き保存)は、しておりません。
　また、再現もしません。[ 疑うなら、コードを　調べてください。]
　あなたは、自動保存をするように設定しているのでしょう。
だったら、自動保存をしないように　設定を変えるべきです。

お礼

書込み有難う御座いました。
＞検索結果該当するものが、複数のシートであったら　あなたは、どうしたいのですか?。
につきましては最初の質問で書かせていただきましたが、検索されたセルが有る一行に色を塗りつぶし、又次を検索したら一行に色を塗りつぶすようにしたかったのです。もしくは検索されたセルが有る行を選択する事によって色が変わり検索結果がわかりやすくし又次の検索候補を選択した時に同じ様に行全体を選択状態にしわかりやすくしたかったのです。それは最初から変わりません。
マクロについては初心者なのですがもしこのような事が出来てみんなに使いやすいファイルとする事が出来ればと思い質問させていただきました。

＞そもそも、全30シートもあるなんで、メモリーの無駄使いです。
だから、探しにくいのです。そして、エクセルの仕様の問題でエラーになるのですよ
につきましては「希望あれば、言ってください」と言っていただいたので御言葉に甘えて書込みさせていただきました。希望仕様がデータ数、バージョン等で無理なようなのであきらめます。

＞2.上書き保存しないで閉じても、次回開くと前回の検索結果で着色されたままで保存
の件につきましては、試させていただいた時の閉じ方が誤っていたのか今やってみると再現しませんでした。自動保存はしていないのですが。大変申し訳御座いませんでした。

これ以上は御迷惑になるみたいですので明日締め切りとさせていただきます。いろいろアドバイスいただき有難う御座いました。

回答No.6

Nayuta_X

これで、どうですか??。

'Option Explicit

Const My_Color As Integer = 36
Dim sh As Worksheet
Dim myR As Range
Dim mV As Integer
Dim Ops As String

Sub 検索color_999()
S = InputBox("検索文字列＝")
If S = "" Then
Exit Sub
End If

Ops = ActiveSheet.Name

Application.ScreenUpdating = False
Sheets_Count = Application.Sheets.Count

For n = 1 To Sheets_Count

Sheets(n).Select
ActiveSheet.UsedRange.Select
Hx = ActiveWindow.RangeSelection.EntireColumn.Count
Range("A1").Select
Set myR = Range(Cells(1, 1), Cells(1, Hx - 1))

Set x = ActiveSheet.Cells.Find(what:=S, MatchByte:=False)

If x Is Nothing Then GoTo p1
b = ActiveSheet.Name & x.Address
x.Activate
mV = Selection.Row
myR.Offset(mV - 1, 0).Select
Selection.Interior.ColorIndex = My_Color
x.Select

'---

Do
Set y = ActiveSheet.Cells.FindNext(after:=ActiveCell)

If y Is Nothing Then GoTo p1
If ActiveSheet.Name & y.Address = b Then GoTo p1

y.Activate
mV = Selection.Row
myR.Offset(mV - 1, 0).Select
Selection.Interior.ColorIndex = My_Color
y.Select

Loop
p1:

Range("A1").Select
Next n

Application.ScreenUpdating = True
Sheets(Ops).Select
MsgBox "検索が終了しました。", vbOKOnly

End Sub

コメント;

< For Each sh In ActiveWorkbook.Worksheetsを入れて見たのですが >
に関して

先のものは、
For

next

は、使用していないので、当然エラーになります。

下記　URL から
繰り返し処理(For～Next、Do～Loop) 　を勉強して　ください。

参考URL：

http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/

お礼

度々恐れ入ります。
1.着色されるのですが検索されたシートへ飛びません。元のシート画面のままです。
2.上書き保存しないで閉じても、次回開くと前回の検索結果で着色されたままで保存されてしまいます。

回答No.5

Nayuta_X

これで、よいですか??。
これだと　1シート　だけの検索になりますが??。

'Option Explicit

Const My_Color As Integer = 36

Sub 検索color_TEST()
S = InputBox("検索文字列＝")
If S = "" Then
Exit Sub
End If

Dim sh As Worksheet

Set x = ActiveSheet.Cells.Find(what:=S, MatchByte:=False)

If x Is Nothing Then GoTo p1
b = ActiveSheet.Name & x.Address
x.Activate

Rows(x.Row).Select
Selection.Interior.ColorIndex = My_Color
x.Select

'---

Do
Set y = ActiveSheet.Cells.FindNext(after:=ActiveCell)

If y Is Nothing Then GoTo p1
If ActiveSheet.Name & y.Address = b Then GoTo p1

y.Activate

Rows(y.Row).Select
Selection.Interior.ColorIndex = My_Color
y.Select

Loop
p1:
' Next
End Sub

お礼

書込み有難う御座いました。
1シートだけであればこれで良いのですがやはり約30シートの検索になります。
上記
Dim sh As Worksheet
の後に
For Each sh In ActiveWorkbook.Worksheets
を入れて見たのですが
「コンパイルエラー　Forに対するNextがありません」とエラーメッセージが出てしまいます。

回答No.4

Nayuta_X

< 検索出来ませんでした > ?????
使用の問題を回避する為に、検索出来た、セルのみに着色しています。　行全体には、着色していません。
いま、MEでも　試験しましたが、ちゃんと　検索出来ています。

どうしても、ダメな場合は、一行めから　3行目までの　データを送ってください。
もちろん、さしさわりのない　部分でよいです。
待っています。

お礼

昨日の時点ではわからなかったのですが、今わかりましたが確かに検索結果に着色されている時も有ったり検索事態されていなかったりです。
着色されている時はグルグルーットっとブック内を回って最後のシートの画面で止まってしまうので着色されていたのがわかりませんでした。
検索結果が有ったシートの画面を表示したいのです。
恐れ入りますが希望と違う点を以下率直に記載させていただきます。
宜しく御願いします。
1.グルグルーットっと検索でなくCtrl＋Fで検索する時のように検索結果に瞬時に飛びたい。
2.現状検索されたセルのみに着色されていますが行全体を着色したい。それが無理な場合行選択し、あたかも着色されているかのように検索行がはっきりわかるようにしたい。

＞どうしても、ダメな場合は、一行めから　3行目までの　データを＞送ってください。
の件はどちらへどうやって送っていいのかわからないのですが以下の感じです。（具体的には書けなくあくまでも例ですが）

シート1
　　A列　　B列　　　C列
1　社名あ　部署あ　氏名あ
2　社名い　部署い　氏名い
3　社名う　部署う　氏名う
　　　　　　　・
　　　　　　　・
　　　　　　　・

シート2以降同様にシート30迄です。

回答No.3

Nayuta_X

一応完成しました。
テストをして　不具合をレポートしてください。
' 下記　コードを　ThisWorkbookに書き込む　または、コピペします。

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

On Error Resume Next

Set flt = ActiveSheet.AutoFilter

Range("A1:B1").Offset(0, SetCeii).Select

If flt Is Nothing Then
Selection.AutoFilter
Else
' AutoFilter を解除する
Selection.AutoFilter
Range("A1").Select
End
End If

Selection.AutoFilter Field:=1, Criteria1:="1"
Range("A1").Select
End Sub

'********** 以下は、標準モジュールに書き込み　まは、コピペします。

' 使用方法
'
' 検索するときは、検索color　を実行します。
' 検索された セルのみに、着色　されます。
' 色を変更する場合、Public Const My_Color As Integer = 36　の数字を変更します。
' 検索された行だけを、表示したい時は、そのシートで、ダブルクリックします。
' すると　オートフィルタが、かかり　その部分だけ(一行目から　データが、入っている場合は、一行目も)表示されます。
' 着色をすべて　なし　にする場合は、初期に戻す　を実行します。
' ダブルクリックで、そのシートだけ　オートフィルタを　解除することも　できます。
'
' オートフィルタの条件は、現在　31　列目( AE列 )に　設定されています。
' もし、この列に　データが、ある場合は、Public Const SetCeii As Integer = 30　の数字を変更します。

Public Const SetCeii As Integer = 30
Public Const My_Color As Integer = 36

Dim flt As AutoFilter
Dim Sh As Worksheet

Sub 検索color()

S = InputBox("検索文字列＝")

If S = "" Then
Exit Sub
End If

sh_Name = ""

On Error Resume Next

For Each Sh In ActiveWorkbook.Worksheets
Sh.Activate
Set flt = ActiveSheet.AutoFilter

If flt Is Nothing Then

Else
Selection.AutoFilter
End If

ActiveSheet.UsedRange.Select
Vy = ActiveWindow.RangeSelection.EntireRow.Count
Range("A1").Select

Set x = Sh.Cells.Find(what:=S, MatchByte:=False)
b = Sh.Name & x.Address
x.Activate

If x Is Nothing Then GoTo p1

If Sh.Name <> sh_Name Then
sh_Name = Sh.Name
Columns("A:A").Offset(0, SetCeii + 2).Select
Selection.ClearContents

For j = 1 To Vy + 1
Range("A1").Offset(j - 1, SetCeii) = 0
Next j

Range("A1").Select
End If

Rows(x.Row).Select
Range("A1").Offset(x.Row - 1, SetCeii) = 1
x.Select
Selection.Interior.ColorIndex = My_Color

Do
Set y = Sh.Cells.FindNext(after:=ActiveCell)

If y Is Nothing Then Exit Do

If Sh.Name & y.Address = b Then Exit Do
Rows(y.Row).Select
Range("A1").Offset(y.Row - 1, SetCeii) = 1
Rows(y.Row).Select
y.Activate
y.Select
Selection.Interior.ColorIndex = My_Color
Loop
'
' 下記コードは、エクセルの仕様の問題が、発生しそうなので、コメント行にしています。
' 解除して　問題あれば、元に(コメント行)戻してください。
'
' Range("A1:B1").Offset(0, SetCeii + 2).Select
' Selection.AutoFilter
' Selection.AutoFilter Field:=1, Criteria1:="1"

Range("A1").Select
p1:
Next

End Sub

Sub 初期に戻す()

Worksheets_Cunt = Application.Worksheets.Count

For N = 1 To Worksheets_Cunt

Worksheets(N).Activate

Set flt = ActiveSheet.AutoFilter

If flt Is Nothing Then
'　何もしない
Else
' AutoFilter を解除する
Selection.AutoFilter
End If

ActiveSheet.UsedRange.Select
Vy = ActiveWindow.RangeSelection.EntireRow.Count

Cells.Select
Selection.Interior.ColorIndex = xlNone
Columns("A:A").Offset(0, SetCeii).Select
Selection.ClearContents
Range("A1").Select

Set flt = Nothing

Next N

End Sub

お礼

書き込み有難う御座ます。
せっかく書いていただいたのですが「ThisWorkbookにコピペ」&「標準モジュールにコピペ」させていただきましたが、グルグルーット、ブック内を回ったけど検索出来ませんでした。
「着色をすべてなしにする場合は、初期に戻す」は、元々タイトル行等に色を付けている部分が有るので今回は使用しない予定です。これを実行すると全てのセルの色が無くなってしまうみたいなので。

回答No.1

Nayuta_X

これは、Excel の仕様および制限　によるもので、プログラムの問題では、ありません。
　< Excel97で、試してみました。> 再現出来ます。

各シート10～12列、全30シート計3500行位　なら　十分にエラーになりますよ。

Excelのバージョンアップをお勧めします。

お礼

書き込み有難う御座いました。
行の色を塗り潰さず、検索結果のセルに飛ぶだけであればエラーもなく問題ないのですが。
検索されたセルが有る行を選択する事によって色が変わったように見えるようにした場合もやはりエラーになりますでしょうか？
この方法ならもし大丈夫で有ればどのように記述したらよいでしょうか？宜しく御願いします。