検索マクロ修正

質問

ある文字を全シートから検索するマクロをこちらのサイトで以下マクロを拝見しました。
これでほぼいいのですが以下を修正するにはどうしたら宜しいでしょうか？宜しく御願いします。
(1)検索したセルに飛ぶ前にセル番地が表示されるのを無くしたい。
(2)検索結果が複数有る場合、全セルに飛んでからでないと終了出来ない。砂時計が表示されたまま。
(3)(2)と同様、間違って空白のまま検索ボタン押してしまうと永遠に終了出来ない。

Sub test01()
s = InputBox("検索文字列＝")
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
Set x = sh.Cells.Find(what:=s)
If x Is Nothing Then GoTo p1
MsgBox sh.Name & x.Address
b = sh.Name & x.Address
sh.Activate
x.Activate
'---
Do
Set y = sh.Cells.FindNext(after:=ActiveCell)
If y Is Nothing Then GoTo p1
If sh.Name & y.Address = b Then GoTo p1
MsgBox sh.Name & y.Address
y.Activate
Loop
p1:
Next
End Sub

回答No.6

noname#97729 · ベストアンサー

Find()の引数は

What　 検索するデータを指定 [省略不可]
After　 検索を開始する単一のセルを指定 [省略可能]
LookIn 検索の対象を指定 数式（xlFormulas）、値（xlValues）、
コメント（xlComments） [省略可能]
LookAt　 完全に同一なセルだけを検索（xlWhole）、
一部分でも一致するセルの検索（xlPart） [省略可能]
SeachOrder　 検索方向を指定します。列方向に検索する（xlByColumns）、
行方向に検索する（xlByRows） [省略可能]
SearchDirection 前方に検索（xlNext：規定値）、後方に検索（xlPrevious）[省略可能]
MatchCase　 大文字と小文字を区別する(True）、区別しない（False） [省略可能]
MatchByte　 半角と全角を区別する（True）、 区別しない（True） [省略可能]

となっています。

---------------------------------------------

Sub 検索test()
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
str2 = MsgBox(sh.Name & x.Address, vbOKCancel)
If str2 = vbCancel Then
Exit Sub
End If

'---

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
str1 = MsgBox(sh.Name & y.Address, vbOKCancel)
If str1 = vbCancel Then
Exit Sub
End If

Loop
p1:
Next
End Sub

確認してみました。

お礼

再度書き込み有難う御座いました。
初心者なりにいただきまいた回答を理解するのに参考書を読んでいましたら、検索されたセルに色を塗りつぶすようにしたくなったので以下記述を追記しようとしたのですがどこに入れたらよいでしょうか？出来ればセルでなく検索されたセルが有る行全体に色をつけられればと思います。宜しく御願いします。

Selection.Interio.ColorIndex = 36

回答No.9

noname#97729

私のパソコンではエクセル2000を使っているのですが、
100個や200個では全然問題ないです。

画面が頻繁に動くので、パソコンに負荷が大きいのかもしれません。
簡単な対策として、

ActiveWindow.WindowState = xlMinimized　ブックの最小化
ActiveWindow.WindowState = xlMaximized　ブックの最大化

など入れて、プログラムの実行中に見えなくするのがいいかも、

私もこれ以上アドバイスは無理です。

もう一度、新しい質問にしたほうがいいですよ。

1.どのような処理をするのかはっきりさせて
2.あなたのＰＣの環境を詳しく、CPUやメモリ　WIN,EXCELのバージョン
3.処理させようとしているデータはどのような物か
（レコードにして数万あるとか、シートがどれくらいあるとか、ファイルサイズなど）

もっとスマートなやり方があると思います

お礼

ここまでで大部分は出来ていますので大変感謝しています。
いろいろたくさんのアドバイスをいただき誠に有難う御座いました。

回答No.8

noname#97729

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

----------どうですか

お礼

すいません。
せっかく記述していただいたのですが、ちゃんと色が付く時と、
ダメな時「実行時エラー'1004':　InteriorクラスのColorIndexプロパティを設定できません」とメッセージが出る時が有ります。
又検索した候補全てに色が付くようにしていただいたのですが、
もし１文字入れて候補が100個有ったら全てに色が付くのでしょうか？
もし検索結果が多すぎる事によるエラーであれば
ANo.7のようにダイアログボックスは要らないのですが、一行づつでもいいかなとも思います。
何度もすいません。宜しく御願いします。

補足

質問者です。
もし色を付けるのでエラーになってしまうようでしたら
行を塗り潰さなくても、行を選択するだけでも色が付きわかりやすくなり構わないので宜しく御願いします。

回答No.7

noname#97729

これで、目的どうりになっていると思います。
テストしてみて下さい。
少ないデータで確認はしています。

それと、逆に色を検索マクロでとりのぞくには

Selection.Interior.ColorIndex = 36　を
Selection.Interior.ColorIndex = xlNone　に変更する。

-----------------------------------------------------

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

str2 = MsgBox("色をつけますか？", vbYesNoCancel, sh.Name & x.Address)
If str2 = vbCancel Then
Exit Sub
End If
If str2 = vbYes Then
Rows(x.Row).Select
Selection.Interior.ColorIndex = 36
x.Select
End If

'---

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

str1 = MsgBox("色をつけますか？", vbYesNoCancel, sh.Name & y.Address)
If str1 = vbCancel Then
Exit Sub
End If
If str1 = vbYes Then
Rows(y.Row).Select
Selection.Interior.ColorIndex = 36
y.Select
End If

Loop
p1:
Next
End Sub

お礼

書き込み有り難う御座います。
「色をつけますか？」のダイアログボックスが出るのですが
これなしで検索したらすぐに行に色をつけてしまいたく
以下を削除したりして試していたのですがどうもうまくいきません。
単純に以下を削除するだけではダメなのでしょうか？
宜しく御願いします。

str2 = MsgBox("色をつけますか？", vbYesNoCancel, sh.Name & x.Address)
If str2 = vbCancel Then
Exit Sub
End If
If str2 = vbYes Then
　　　・
　　　・
str1 = MsgBox("色をつけますか？", vbYesNoCancel, sh.Name & y.Address)
If str1 = vbCancel Then
Exit Sub
End If
If str1 = vbYes Then

回答No.5

noname#97729

すいません、もう少し修正

Sub 検索test()
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)
If x Is Nothing Then GoTo p1
b = sh.Name & x.Address
sh.Activate
x.Activate
str2 = MsgBox(sh.Name & x.Address, vbOKCancel)
If str2 = vbCancel Then
Exit Sub
End If

'---

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
str1 = MsgBox(sh.Name & y.Address, vbOKCancel)
If str1 = vbCancel Then
Exit Sub
End If

Loop
p1:
Next
End Sub

お礼

再度書き込み有難う御座いました。
もう少し教えて下さい。
半角と全角を区別する事なく検索するには以下のような記述をWebで見つけましたがどこに入れるのかと今回記述いただきました時もこれでいいのでしょうか？宜しく御願いします。

ActiveCell.Find what:=ActiveCell.Value, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
matchbyte:=False

回答No.4

noname#97729

マクロの修正をしました。

Sub test01()
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)
If x Is Nothing Then GoTo p1
b = sh.Name & x.Address
sh.Activate
x.Activate
MsgBox sh.Name & x.Address

'---

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

str1 = MsgBox(sh.Name & y.Address, vbOKCancel)

If str1 = vbCancel Then
Exit Sub
End If

y.Activate
Loop
p1:
Next
End Sub

どうでしょう。

回答No.3

Wendy02

こんばんは。

>シートがたくさんある時、最後のシート迄「グルグルーット」回って検索が終了されるのを改善出来ますでしょうか？

そういうつもりで作ったはずですが、そうではないのですか？
ご質問の(1)～(3)を理解して修正したはずですが、違うのでしょうか、ご指摘の意味が分かりません。試していただけたのでしょうか？

時々、実際に試さないでコードをみただけで返事をする人がいますけれども。

検索して見つけて、どうするか、ということです。それが、止まらなかったら、何もなりませんよね。ただ、UserForm を付けて、一覧にしたいというような話になると、それなりに、ご質問者さん側がVBE の取り扱いの問題に発展してきてしまいます。こちら側では、そこまでは、難しいと思います。

>出来ればCtrl+Fのような感じで

マクロのショートカットは、ツール－マクロ－マクロで、
窓を出して、オプションで登録すればよいと思います。
なるべく、既存のものとぶつからないようにすればよいです。

>Excel97以上で動くようにしたいです。宜しく御願いします。

一応、コードを見る限りは、97でも動くはずです。
動かないのですか？原則的には、ここでは製作依頼という方向では書けませんので、あらかじめご了承ください。

お礼

再度書き込み有難う御座いました。
>シートがたくさんある時、最後のシート迄「グルグルーット」回っては
記述していただいたマクロ試させていただきました。
Ctrl+Fで検索する時は一瞬で飛ぶので「グルグルーット」とは回らないのでと思ったのですが、おっしゃる通りCtrl+Fで検索すると複数検索一致が有った時に又1個目の検索結果セルに飛ぶので同じ文字箇所が又検索されるのは意味がないかもしれません。

>出来ればCtrl+Fのような感じで
は、表現不足ですいません。キーを割り当てるのではなく上記の「グルグルーット」とは回らず一瞬でセルに飛んだらと言う意味でした。

>Excel97以上で動くようにしたいです
は、自分は2000なのですが、他の人が97で使われる可能性が有る為でした。

回答No.2

Wendy02

こんばんは。

今回は、元のコードを直しただけです。特別に何かをしているわけでもありませんが、ただ、Find の部分は、あまり省略すると、誤動作する恐れがあります。かといって、こちらての決め付けることも出来ませんので、そのままにしておきます。

Range(....).Find(What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)

Find メソッドは、どうも、デフォルトは、ユーザーマニュアル設定に、その設定値が残ってしまうようなので、あまりデフォルトをあてにしないほうがよいです。ヘルプをみて、ご自分で直してください。

'標準モジュール

Sub SearchTest()
　　Dim sText As String
　　Dim sh As Worksheet
　　Dim c As Range
　　Dim myAddress As String
　　sText = Application.InputBox("検索文字列＝", Type:=2)
　　If sText = "" Or StrComp(sText, "False", vbTextCompare) = 0 Then Exit Sub

　　For Each sh In ActiveWorkbook.Worksheets
　　　　sh.Select
　　　　Set c = sh.Cells.Find(what:=sText)
　　　　If Not c Is Nothing Then
　　　　　　c.Select
　　　　　　myAddress = c.Address
　　　　　　If MsgBox("継続しますか？", vbOKCancel) = vbCancel Then
　　　　　　　　Exit Sub
　　　　　　End If
　　　　　　Do
　　　　　　　　Set c = sh.Cells.FindNext(after:=ActiveCell)
　　　　　　　　If Not c Is Nothing Then
　　　　　　　　　　If myAddress = c.Address Then Exit Do
　　　　　　　　　　c.Select
　　　　　　　　　　If MsgBox("継続しますか？", vbOKCancel) = vbCancel Then
　　　　　　　　　　　　Exit Sub
　　　　　　　　　　Else
　　　　　　　　　　　　Exit Do
　　　　　　　　　　End If
　　　　　　　　Else
　　　　　　　　　　Exit Do
　　　　　　　　End If
　　　　　　Loop
　　　　End If
　　　　myAddress = ""
　　Next sh
End Sub

お礼

書き込み有難う御座いました。
シートがたくさんある時、最後のシート迄「グルグルーット」回って検索が終了されるのを改善出来ますでしょうか？
出来ればCtrl+Fのような感じで

アプリケーション名書くのを忘れていてすいません。
Excel97以上で動くようにしたいです。宜しく御願いします。

回答No.1

noname#97729

エクセルの検索のフリーソフトはいろいろありますよ。
探して見てはどうでしょう。

例えば

http://www.vector.co.jp/soft/win95/util/se418785.html

http://www.vector.co.jp/soft/win95/business/se408581.html

お礼

書き込み有難う御座いました。
出来ればマクロでと思っています。
でも検索フリーソフトがこのように有るのは大変参考になりました。