エクセルVBAであいまい検索フォームを作りたいです。

質問

エクセルVBAであいまい検索フォームを作りたいです。
（Ctrl+Fではなく）

商品群A・商品群B・商品群C・・・・と分けられたシートの
すべてのA列に、商品名が入っています。

テキストボックスと【検索】ボタンと【次を検索】ボタンのみの
単純な検索用ユーザーフォームから
商品名をシートをまたいで検索し、
Ctrl+Fと同じように該当セルに移動、
次を検索で次の商品へ移動、

すべてのシートに該当商品が無ければ
メッセージボックス「該当する商品はありません」

なんとなく出来そうな気がしてチャレンジしましたが、
基本がなっていないため行き詰りました。
（自動マクロを少しいじる程度なので・・・）

とんでもなく支離滅裂ですが、チャレンジしたゴミコードを晒します。
順番がおかしいのは判るのですが、どうすればいいのか。。。

どなたか、このコードを正し添削して頂けませんか。
（あ、このコードにこだわっているわけではないので、
もっと他に適した方法があるのなら、それを教えてください）
よろしくお願い致します。

ちなみに、作成はexcel2007ですが、2000・2003に配布します。

Dim s As Variant
Dim c As Range
Dim f As Range

For Each s In Worksheets
'ブック内各シートに繰り返し
With s
s.Select
'シートを選択
Set f = Columns("B").Cells
'B列を変数にセット
Set c = f.Find(What:=Trim(strData), LookIn:=xlValues, MatchByte:=False, LookAt:=xlPart)
'FINDでstrData(userformからの入力した文字列)をあいまい検索としてセット
If Not c Is Nothing Then
Application.Goto c, True
'見つかった時は該当セルに飛ぶ
Else

End If
End With
Next

End Sub

回答No.3

mitarashi

昔の記事になってしまいましたが、役に立ったと投票してくださっている方がいらっしゃいますので、バグフィックスです。'<-追加　とある３カ所を追加願います。 これで、実行時エラーで止まる事が減ると思います。
本コードを応用して、エクセルの検索ダイアログのまがい物を作成し、アドインにして使っています。2000文字には収まらないので、まるごと投稿するのは断念しました。
Do
targetBook.Activate
Worksheets(currentSheetID).Activate
With targetBook.Worksheets(currentSheetID)
If Not (.UsedRange.Cells.Count = 1 And IsEmpty(.UsedRange)) Then
If firstAddress = "" Then
With targetBook.Worksheets(currentSheetID).UsedRange
On Error Resume Next '<- 追加
Set c = .Find(Me.findStrTextBox.Value, LookIn:=lookInMode, LookAt:=matchMode, _
SearchOrder:=orderMode, SearchDirection:=xlNext, MatchCase:=caseMode, MatchByte:=mbMode)
On Error GoTo 0 '<- 追加
End With
If Not c Is Nothing Then
firstAddress = c.Address
previousAddress = c.Address
c.Activate
Exit Sub
End If
Else
With targetBook.Worksheets(currentSheetID).UsedRange
Set c = .Range(previousAddress)
Set c = .FindNext(c)
End With
If (Not c Is Nothing) And (c.Address <> firstAddress) Then
previousAddress = c.Address
c.Activate
Exit Sub
End If
End If
End If
End With
currentSheetID = currentSheetID + 1
firstAddress = ""
Set c = Nothing '<- 追加
Loop While currentSheetID <= targetBook.Worksheets.Count

回答No.2

mitarashi

#1です。ブックを明示する位しか思いつきません。それでダメなら、当方では検証できませんので、あしからず。
Labelは止めて、グローバル変数にしました。
☆標準モジュール
Sub showForm()
UserForm1.Show vbModeless
End Sub
☆フォームモジュール
Dim targetBook As Workbook
Dim currentSheetID As Long
Dim firstAddress As String
Dim previousAddress As String

Private Sub CommandButton1_Click()
Dim c As Range

If Me.TextBox1.Value = "" Then Exit Sub
If currentSheetID = 0 Then currentSheetID = 1
Do
targetBook.Activate
Worksheets(currentSheetID).Activate
If firstAddress = "" Then
With targetBook.Worksheets(currentSheetID).UsedRange
Set c = .Find(Me.TextBox1.Value, LookIn:=xlValue, lookat:=xlPart)
End With
If Not c Is Nothing Then
firstAddress = c.Address
previousAddress = c.Address
c.Activate
Exit Sub
End If
Else
With targetBook.Worksheets(currentSheetID).UsedRange
Set c = .Range(previousAddress)
Set c = .FindNext(c)
End With
If (Not c Is Nothing) And (c.Address <> firstAddress) Then
previousAddress = c.Address
c.Activate
Exit Sub
End If
End If
currentSheetID = currentSheetID + 1
firstAddress = ""
Loop While currentSheetID <= targetBook.Worksheets.Count
Me.TextBox1.Value = ""
Call initialize
MsgBox "検索終了"
End Sub

Private Sub UserForm_Initialize()
Set targetBook = ActiveWorkbook
End Sub

Private Sub initialize()
currentSheetID = 0
firstAddress = ""
previousAddress = ""
End Sub
アドイン化してみました。その場合は、xla形式で保存します。
☆Workbookモジュール
Private Sub Workbook_AddinInstall()
Dim menu As Object, Submenu1 As Object
Set menu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)
menu.Caption = "全シート検索"
Set Submenu1 = menu.Controls.Add
Submenu1.Caption = "検索フォーム表示"
Submenu1.OnAction = "showForm"
End Sub

Private Sub Workbook_AddinUninstall()
Application.CommandBars("Worksheet Menu Bar").Controls("全シート検索").Delete
End Sub

回答No.1

mitarashi

昔から気になっていたので、試みに作成してみました。当方xl2000です。
UserFormに、TextBox1,CommandButton1の他に、Label1,2,3を作成します。変数の内容が視認できて、デバッグが楽そうなので、Labelを用いてみました。動くようになったら、各Labelのプロパティを不可視にします。一部ご質問の内容と異なり、各シートのUsedRange全体を検索しています。
2007で動くか、また、安定動作は自信がありませんが、ご参考まで。
'標準モジュール
Sub test()
UserForm1.Show vbModeless
End Sub

'UserForm1のモジュール
Private Sub CommandButton1_Click()
Dim currentSheetID As Long
Dim c As Range

If Me.TextBox1.Value = "" Then Exit Sub
If Me.Label1.Caption = "" Then Me.Label1.Caption = CStr(1)
Do
currentSheetID = Val(Me.Label1.Caption)
Worksheets(currentSheetID).Activate
If Me.Label2.Caption = "" Then
'first find
With Worksheets(currentSheetID).UsedRange
Set c = .Find(Me.TextBox1.Value, LookIn:=xlValue, lookat:=xlPart)
End With
If Not c Is Nothing Then
Me.Label2.Caption = c.Address 'firstAddress
Me.Label3.Caption = c.Address 'previousAddress
c.Activate
Exit Sub
End If
Else
'findnext
With Worksheets(currentSheetID).UsedRange
Set c = .Range(Me.Label3.Caption)
Set c = .FindNext(c)
End With
If (Not c Is Nothing) And (c.Address <> Me.Label2.Caption) Then
Me.Label3.Caption = c.Address
c.Activate
Exit Sub
End If
End If
currentSheetID = currentSheetID + 1
Me.Label1.Caption = CStr(currentSheetID)
Me.Label2.Caption = ""
Loop While currentSheetID <= ActiveWorkbook.Worksheets.Count
Me.TextBox1.Value = ""
Call initialize
MsgBox "検索終了しました"
End Sub

Private Sub UserForm_Initialize()
Call initialize
End Sub

Private Sub initialize()
Me.Label1.Caption = ""
Me.Label2.Caption = ""
Me.Label3.Caption = ""
End Sub

補足

早速のレスありがとうございます。

試してみたところ、
”インデックスが有効範囲にありません”
Set c =.Find(Me.TextBox1.Value, LookIn:=xlValue, lookat:=xlPart)
に黄マーカーが入ります。

Findの使い方もよく分かっていませんが、
■■■の部分に、検索先オブジェクトを指定しなくてもいいのでしょうか？
Set c =■■■.Find(Me.TextBox1.Value, LookIn:=xlValue, lookat:=xlPart)

とんちんかんな事を言っていたらすみません。
引き続きご教授いただけると嬉しいです。