フォルダ内の複数ファイルの一括検索マクロ

Question

⑴ 同一フォルダ内にある20ぐらいのエクセルファイルの住所の一部や、電話番号の一部を文字列検索して、エクセルの機能にある「ブック・全て検索」の結果と同じような
   「ブック」「シート」「名前」「セル」「値」
を全て表示させ、「セル」にはリンク設定をして、ジャンプするようにしたいのです。
⑵ エクセルファイルは、
     列データは統一されておらず、18列程度
     それぞれ別のファイル名、シート名が付いている
     1ファイルに5万行程度のデータ
     データは電話番号、氏名、住所、顧客情報、備考など
です。
会社のPCでは、ネットやアプリが使えず、エクセルのマクロでしたいと思っています。
ただ、このためにマクロをやりだしたため、殆ど分からず、ネットで調べて近い物を参考にいくつか書かれていたマクロの記述を見ながら作りましたが、うまく動きません
勉強しても全く追いつかないので、どなたか親切な方、作って頂けませんでしょうか
エクセルは2010です。
どうぞ、よろしくお願いします。

30246kiku · Accepted Answer

＃６です

> 何分、マクロに関しては素人ですので、

回答した、回答いただいてるので、色々聞かれたら良いと思いますよ
質問者さんが補足等で聞かれる分には、遠慮はいらないと思います

ご質問内で、リンク設定して･･･とあったので、
ハイパーリンクでの記述を提示してみましたが、
ハイパーリンクを使わない理由に（私は）興味ありますけど

ハイパーリンクを使わないから、
シートモジュールへの記述が発生していると思われるので

素人ゆえに、機能を増やす/削る等の判断は重要かと
機会があれば、色々な事を知っておいた方が良いかも
それによって、VBA での記述量/難易度が変わってくると思います

※
> 同一フォルダ内にある20ぐらいのエクセルファイル

これらのファイルの性質はどのようなものだったでしょうか
随時更新され続けるものだったでしょうか？

言葉で記述してませんでしたが
・AddFile してから Search するまでの間に
・Search してから Search するまでの間に
ファイルサイズが変わったら、読み込みしなおすようにしてました
不要であれば、Size 比較部分等削除ください
ファイルサイズが変わらない場合でも、現状で動くと思います
サイズで判別していましたが、更新日時を使うとか・・・

履歴の様なもので今後変更ないのであれば、
Access にでも１枚テーブルに読み込んでおけば
And 検索等も楽にできるような気がします

※ そのまま 使えるもの を提示しているつもりは無いので、
検証を重ねて、できるもの から、使えるもの にしてください

例えば、Samp0 でのファイルの指定方法とか

CPATH のフォルダにある Excel ファイルを AddFile に指定しますが、
ファイル名先頭が "~" なら除外してました
これは、自分が（誰かが）そのファイルを開いた時に出来上がる
バックアップファイル（？）の ~$ファイル名 を対象外とするだけです

なので、普通に "~" で始っているとか
> マクロを設定したエクセルをデータがあるフォルダと同じフォルダに保存
には対応できてません

ファイル名を得るために FileSystemObject のメソッド を使ってました

FileSystemObject のメソッド
https://msdn.microsoft.com/ja-jp/library/cc428078.aspx

Dir を使っても良いと思います
どのような指定をしたら、どのようなものが得られるのか等
また、それによって、どのような判別すれば良いのか・・・
色々試してみてください

WindFaller · Answer

こんばんは。

WindFallerです。

>フォルダを指定すると、一応検索しているような間がありますが、検索結果は出て来ず、「終了！」のダイアログが表示されます。

バグフィックス前のものですと、途中でエラーが発生していますので、そのような結果になります。ただ、実際のエラーは、黄色になっている部分よりも前の段階ではないかと思います。

>Public ShName As String　'本来は、JampMacroの引数
>Public CellAdd As String　'本来は、JampMacroの引数
この2つを貼り付けていないと、エラーが発生します。たぶん、このモジュール変数は、中に取り込む予定はしていますが、今回には間に合わないような気がしています。

>junpmacroではインデックスが有効範囲にありませんと出て、デバックを確認すると、「ジャンプマクロ……」の２行下のapplication.goto …の行が黄色く示され、認識してくれていないようです。

数式の部分をダブルクリックして、インデックスが有効の範囲ではないと出るのは、何か、別の文字が混じりこんだせいだと思います。途中で変わるのか、はっきりとした理由はわかりません。数式で、リンクが完全に分離できていないかもしれません。これは、丁寧に調べないとわかりません。インデックスは、ワークシート名が正しく取得できないからでしょうけれども、
.Worksheets(ShName).Range(CellAdd)
このShName をローカルウィンドウで確認していただく必要があります。
その上のコードを追いかけても、ややこしいと思います。この部分は、もっと簡単に分けるユーザー定義関数の用意もありますが、原因が分からないままにはできません。

>マクロを設定したエクセルをデータがあるフォルダと同じフォルダに保存して、そのフォルダを指定せずに検索出来ればいいなと思っています。

私自身のマクロには、その予定はありませんが、比較的カンタンな作業です。

If serTxt = "False" Or Trim(serTxt) = "" Then Exit Sub
'------------------------------
　With Application.FileDialog(msoFileDialogFolderPicker)
　　If .Show = True Then
　　　myPath = .SelectedItems(1) & "\"
　　End If
　End With
　If myPath = "" Then Exit Sub
'---------------------------------

ここ間で、そのファイル自体のフォルダーなら、
以下の1行になります。

myPath = ThisWorkbook.Path &"\"　'←必ず￥(半角）を最後に入れてください。

その次の行で、自分を検索しないようにするために、
'-----------------編集後----
If serTxt = "False" Or Trim(serTxt) = "" Then Exit Sub

myPath = ThisWorkbook.Path & "\"
　FName = Dir(myPath & FileHead & "*." & EXT, vbNormal) 'Excelファイル限定
　Do While FName <> ""
　　If FName <> "." And FName <> ".." And FName <> ThisWorkbook.Name Then　'ここに加える
　　　If (GetAttr(myPath & FName) And vbNormal) = vbNormal Then
　　　　myArray(i) = FName
　　　　i = i + 1
　　　　If i > 2000 Then Exit Do　'ここを変更する(追加のバグ）
　　　End If
　　End If
　　FName = Dir
　Loop

>#1と#2を連続して一つのマクロにするのはダメなのでしょうか？
連続してというのは、よく意味がわかりませんが、働きが違いますから、それを一つにするとことは考えていません。#1だけでお使いになってもよいかもしれません。

したがって、
>「セル」にはリンク設定をして、ジャンプするようにしたいのです。
ジャンプはしなくなります。

私としては、私自身のためもあって作ったものですから、ご質問者様自身のご要求には満たないのかもしれません。そして、基本的には、大幅な仕様変更は望んでいません。現在、私は、1万語以上の英単語とその例文と訳をExcelで保有していまして、このマクロは、単語の場所まで探してくれますので、なかなか良く出来ているとは自分では関心しています。

[画像添付] その一つをダブルクリックすると、expulsion　という単語が分かりますが、検索語の後の数式でも、ファイルを開かずに、この英単語を取り出すことが可能です。

昔、Access でも似たようなものは作ったことがあるのですが、このように多岐に渡った検索はしません。これは、複数のCSVファイルでも、検索してくれるので、私自身は、かなり気に入ったものになりました。環境は、Excel 2010, Windows 7

私の後に、いつも回答をつけていただける方が来ましたので、私のものの修正やバグ潰しをする意味がないと思いましたら、どうぞ、未練なく、こちらのコードは見捨てて、別のマクロをお使いください。

ただ、見切った後への、私のコードのへのコメントやご批判は、どなたもご遠慮くださいますようにお願いします。私自身は、バグフィックス版において、今のところ問題は出ていませんから。

掲示板では、ある程度、老婆心や親切心よりも、質問者さんの要望の骨子を提供しなければならないのは分かっていますが、私には、得てして、そういう見切りができません。

フォルダー選択やシートのデータを削除される前のダイアログが出ることも、親切心なのです。それがいらなければ、それを取り除くだけです。ジャンプさせるのも、ハイパーリンクを作ればよいことですが、それをしなかったのは、理由があってのことです。ハイパーリンク一つ出力すれば、後は、プログラム的には、何も入りません。私は、実際、ハイパーリンクを何度か試してみて、その方法を選びませんでした。個人で使う場合も、そのような方法は選びません。

しかし、そういう思惑的に違う部分が多ければ、もう、すでに、このマクロは失敗しているといえるかもしれません。

なお、検索後の正しい結果です。前回のは間違っていたようです。
以下70データ、14ファイルの検索の出力をしています。

30246kiku · Answer

【つづき】

作成したクラス clsSearch を利用して複数の Excel ファイルを検索していきます

clsSearch 内には、
・同時に検索するファイルを指定しておく AddFile
・検索を実行する Search
等が用意されています

AddFile の引数は、ファイルのフルパス[、読み込みパスワード]
Search の引数は、検索語、書き出しセル
書き出しセル位置から、
フォルダパス、ファイル名、シート名、セル位置、内容 の５つが表示されていきます
セル位置 部分にはハイパーリンクが設定されます。

使い方としては、例えば標準モジュールに

Option Explicit

Dim clsS As clsSearch

Public Sub Samp0()
　　Dim v As Variant
　　Const CPATH As String = "D:\Hoge\Hogehoge" ' ファイルがあるフォルダパス

Set clsS = New clsSearch
　　With CreateObject("Scripting.FileSystemObject")
　　　　For Each v In .GetFolder(CPATH).Files
　　　　　　If (LCase(.GetExtensionName(v.Name)) Like "xls*") Then
　　　　　　　　If (Left(v.Name, 1) <> "~") Then clsS.AddFile v.Path
　　　　　　End If
　　　　Next
　　End With
End Sub

Public Sub Samp1()
　　Dim sS As String
　　Dim v As Variant
　　Dim iR As Long

If (clsS Is Nothing) Then Call Samp0
　　Do While (1)
　　　　sS = InputBox("検索語の入力")
　　　　If (Len(sS) = 0) Then Exit Do
　　　　Application.ScreenUpdating = False
'　　　　Worksheets.Add ' ★
　　　　iR = 1
　　　　For Each v In Split(sS, ",")
　　　　　　With Cells(iR, "A")
　　　　　　　　.Resize(, 5).Value = Array("フォルダ", "ファイル名" _
　　　　　　　　　　　　　　　　, "シート名", "セル位置", "検索値： " & v)
　　　　　　　　clsS.Search Trim(v), .Offset(1)
　　　　　　　　With .CurrentRegion
　　　　　　　　　　.Rows(1).Interior.ColorIndex = 15
　　　　　　　　　　.Borders.LineStyle = xlContinuous
　　　　　　　　End With
　　　　　　End With
　　　　　　iR = Cells(Rows.Count, "A").End(xlUp).Row + 2
　　　　Next
　　　　Columns.AutoFit
　　　　Application.ScreenUpdating = True
　　Loop
　　Set clsS = Nothing
End Sub

※ Samp0 で、同時検索するファイルのフルパスを指定して AddFile
クラスの動きとして、AddFile した時点で、
不可視の（見えない）Excel を起動してファイルを Open しておきます

読み込んで Open したものを対象に
Search で、検索語、書き出しセルを指定して実行します（ Samp1 ）

Samp1 の動作として、検索語の指定では、"," 区切りで検索します
★ を有効にすると、１回の検索で新規シートを作成しますが、
"," 区切りで検索したものは同一シートに

Samp1 の作り方次第で、如何様にも処理変形できると思います。
Search は、今まで指定した AddFile した全シートを検索するので･･･

※ 検索のたびに、毎回、Excel ファイルを Open して･･･
ある程度 OS 側のキャッシュに乗っかるかもしれないけど･･･
AddFile された時点で Open しておけば２度目以降の検索は少しでも速くなるのでは？？

ただ、どのような操作を続けていくのかわからないので･･･
例えば、提示した Samp1 最後の、

>　　Set clsS = Nothing

をしなかったとすると、継続して Samp1 実行することができますが、
出来上がったシートのセル位置部分にハイパーリンクが設定されており、
そのハイパーリンクをクリックすると、
クラス内で非表示にしている Excel ファイルが可視化され表示されてしまいます。
これは、Excel の動きの様で、
ハイパーリンクで起動しようとしているファイルが既に Excel に取込まれているのなら、それを表示するみたい。
もし、その可視化され、閉じる操作をされてしまうと、
次回以降の Search で検索されない状況が発生します。

※ 検索操作は１回ごと･･･なら、できるということが上記でわかると思いますが、
使えるのか・・・は、また違った判断かと思います

Access 等、使った方が楽な様な気もします。
（どのようなことをしたいのか、わかりませんが）

30246kiku · Answer

混乱する様でしたらスルーしてくださいどのような処理の流れなのか、質問内容からは読み取れませんでした検索を続けて行うようなことがあれば、Open しっぱなし状態が良いのか・・・クラスというものを導入されてみてはどうでしょう以下、VBE で、挿入→クラスモジュールした所に記述し、クラス名を clsSearch に変更しておきます（添付図） ※ このクラスに使い方は後述 Option Explicit Private oApp As Excel.Application Private dic As Object Private oFso As Object Private Const CSIZE As String = "Size" Private Const CBOOK As String = "Book" Private Const CPWD As String = "Password" Private Sub Class_Initialize() 　　Set dic = CreateObject("Scripting.Dictionary") 　　Set oFso = CreateObject("Scripting.FileSystemObject") End Sub Private Sub Class_Terminate() 　　Call Me.Clear 　　Set dic = Nothing 　　Set oFso = Nothing End Sub Public Sub Clear() 　　Dim wb As Workbook 　　If (Not oApp Is Nothing) Then 　　　　For Each wb In oApp.Workbooks 　　　　　　wb.Close False 　　　　Next 　　　　oApp.Quit 　　　　Set oApp = Nothing 　　End If 　　dic.RemoveAll End Sub Public Function AddFile(sPath As String, Optional vPw As Variant) As Boolean 　　AddFile = False 　　On Error GoTo ERR_EXIT 　　If (oApp Is Nothing) Then Set oApp = New Excel.Application 　　With oFso.GetFile(sPath) 　　　　If (Not dic.Exists(sPath)) Then 　　　　　　dic.Add sPath, CreateObject("Scripting.Dictionary") 　　　　End If 　　　　dic(sPath)(CSIZE) = .Size 　　End With 　　If (IsMissing(vPw)) Then 　　　　Set dic(sPath)(CBOOK) = _ 　　　　　　oApp.Workbooks.Open(sPath, ReadOnly:=True) 　　Else 　　　　Set dic(sPath)(CBOOK) = _ 　　　　　　oApp.Workbooks.Open(sPath, ReadOnly:=True, Password:=vPw) 　　　　dic(sPath)(CPWD) = vPw 　　End If 　　AddFile = True 　　Exit Function ERR_EXIT: 　　If (dic.Exists(sPath)) Then dic.Remove sPath End Function Public Sub RemoveFile(sPath As String) 　　On Error Resume Next 　　If (dic.Exists(sPath)) Then 　　　　dic(sPath)(CBOOK).Close False 　　　　dic.Remove sPath 　　End If End Sub Public Sub Search(vWord As Variant, ByVal rng As Range) 　　Dim v As Variant 　　Dim ws As Worksheet 　　Dim r As Range 　　Dim sAdr As String 　　With rng.Parent 　　　　Set r = Intersect(.UsedRange, .Rows(rng.Row & ":" & .Rows.Count)) 　　　　If (Not r Is Nothing) Then r.Clear 　　End With 　　If (Len(vWord) = 0) Then Exit Sub 　　If (dic.Count = 0) Then Exit Sub 　　On Error Resume Next 　　For Each v In dic.Keys 　　　　With dic(v) 　　　　　　If (.Item(CSIZE) <> oFso.GetFile(v).Size) Then 　　　　　　　　.Item(CBOOK).Close False 　　　　　　　　If (Not .Exists(CPWD)) Then 　　　　　　　　　　Set .Item(CBOOK) = _ 　　　　　　　　　　　　oApp.Workbooks.Open(v, ReadOnly:=True) 　　　　　　　　Else 　　　　　　　　　　Set .Item(CBOOK) = _ 　　　　　　　　　　　　oApp.Workbooks.Open(v, ReadOnly:=True _ 　　　　　　　　　　　　　　　　　　　　, Password:=.Item(CPWD)) 　　　　　　　　End If 　　　　　　End If 　　　　　　For Each ws In .Item(CBOOK).Worksheets 　　　　　　　　Set r = _ 　　　　　　　　　　ws.Cells.Find(vWord _ 　　　　　　　　　　　　　　, ws.Cells.SpecialCells(xlCellTypeLastCell) _ 　　　　　　　　　　　　　　, LookAt:=xlPart) 　　　　　　　　If (Not r Is Nothing) Then 　　　　　　　　　　sAdr = r.Address 　　　　　　　　　　Do 　　　　　　　　　　　　rng.Resize(, 5) = Array( _ 　　　　　　　　　　　　　　oFso.GetParentFolderName(v) _ 　　　　　　　　　　　　　　, .Item(CBOOK).Name, ws.Name _ 　　　　　　　　　　　　　　, r.Address(False, False), r.Value) 　　　　　　　　　　　　rng.Parent.Hyperlinks.Add rng.Offset(, 3), v _ 　　　　　　　　　　　　　　, "'" & ws.Name & "'!" & r.Address(False, False) 　　　　　　　　　　　　Set rng = rng.Offset(1) 　　　　　　　　　　　　Set r = ws.Cells.FindNext(r) 　　　　　　　　　　Loop While (r.Address <> sAdr) 　　　　　　　　End If 　　　　　　Next 　　　　End With 　　Next End Sub 【つづく】

WindFaller · Answer

補足の件は、後ほど、再びお返事いたします。

本日、別件でPCにトラブルがあり、すぐに取り掛かれませんでした。今、バグの修正をしたばかりです。当面、#1のコードのままでお使いください。

#1のコードの一部を、ご面倒でも修正してください。
不手際がありましたことを、お詫び申し上げます。痛恨のミスです。
なお、プロセスに残ったExcelオブジェクトの除去の仕方が必要でしたから、以下に簡単な方法ですが、示しておきます。(Ctrl+Shift+Esc でタスクマネージャーが起動しますので、プロセスが見られます）

End Sub から、さかのぼり、Set objXl = Nothing　4つ手前、ErrHandler の次に、
objXl.Quit

さらに、ErrHandler:から10行遡り、
If sh.Name & "!" & c.Address = FirstAddress Then Exit Sub を

If sh.Name & "!" & c.Address = FirstAddress Then Exit Do
になおしてください。

プロセスに残ったExcelオブジェクトの除去は、一旦、Excelを終了して、

デスクトップ上に、メモ帳を立ち上げて、以下のコードを貼り付けて、
適当な名前、ReleaseExcel.vbs とでもして、保存します。それをクリックしますと、
隠れていたExcelが現れます。後は、閉じればよいです。

'
Set objXL =GetObject(,"Excel.Application")
objXL.visible =True

WindFaller · Answer

お知らせ。

#1か#2のどちらかに、バグが存在しているようです。
使用上には支障はでないはずですが、検索したブックの終了方法にエラーに発生しています。
今のところ、原因は不明です。
私のアイデア倒れかもしれません。
なるべく早く、原因を突き止めます。

WindFaller · Answer

次は、シャンプ(数式をダブルクリックすることで、目的のファイルを開けて、そこに飛ぶ）マクロです。

'//シートモジュール
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　Dim myAdd As String
　Dim myPath As String
　Dim fn As String
　Dim buf As String
　Dim i, j
　Dim objWb As Workbook
　Dim r
　Cancel = True
　ShName = ""
　CellAdd = ""
　If Target.HasFormula = False Then Exit Sub
　If Target.Formula Like "*[+[|][-][*]/]*" Then Exit Sub '四則演算不可
　myAdd = Target.Formula
　If myAdd Like "='[A-Z]:\*" Then
　　myAdd = Replace(myAdd, "='", "", 1, 1, vbTextCompare)
　　myPath = Left(myAdd, InStrRev(myAdd, "\", , vbTextCompare))
　　myAdd = Mid(myAdd, InStrRev(myAdd, "\", , vbTextCompare) + 1)
　Else
　　myAdd = Replace(myAdd, "=", "", 1, 1, vbTextCompare)
　End If
　i = InStr(1, myAdd, "[", vbTextCompare) + 1
　If i > 1 Then
　j = InStr(i, myAdd, "]", vbTextCompare)
　If i * j = 0 Then MsgBox ("アドレスエラーです。"), vbExclamation: Exit Sub
　fn = Mid(myAdd, i, j - i)
　End If
　buf = Mid$(myAdd, j + 1)
　ShName = Left$(buf, InStr(1, buf, "'!", vbTextCompare) - 1)
　
　If ShName = "" Then
　　ShName = Left$(buf, InStr(1, buf, "!", vbTextCompare) - 2)
　End If
　If fn = "" Then
　　 fn = ThisWorkbook.Name
　End If
　CellAdd = Mid$(buf, InStr(1, buf, "!", vbTextCompare) + 1)
　
　On Error Resume Next
　Set objWb = Workbooks(fn)
　If Err() <> 0 Then
　　With Workbooks.Open(myPath & fn)
　　　'Application.OnTime Now() + TimeSerial(0, 0, 2), "'JumpMacro """ & ShName & """,""" & CellAdd & """'"　　'失敗であるが、こちらのスタイルのほうが正しいはず
　　　
　　　Application.OnTime Now() + TimeSerial(0, 0, 2), "'JumpMacro'"
　　End With
　Else
　　With Workbooks(fn)
　　　Application.Goto .Worksheets(ShName).Range(CellAdd)
　　End With
　End If
　On Error GoTo 0
End Sub

WindFaller · Answer

こんにちは。最初に、久々に納得できる内容に巡り会えたなって気がしました。ただし、今回は、自分のために作ってみました。だから、直す部分はあっても、大幅な変更はしないつもりですから、申し訳ありませんが、勝手を許してください。 >ネットやアプリが使えず、 >ネットで調べて近い物を参考にいくつか書かれていたマクロの記述を見ながら作りましたが、 Excel内をくまなく探す専用のツールあることはあるのですが、私の知っている限りでは、ご質問者さんがいうような便利なアプリはないと思います。あったら、逆に教えてください。更に参考にします。私が持っているのは、hishidaさんのKWIC Finder(有償）です。この方が開発したツールをExcelに組み込むことは可能ですが、思ったほどではありません。質問者さんがいうようなものがあれば、確かに便利だなって思い、昨日がずっと、試行錯誤で作ってみました。 >「ブック」「シート」「名前」「セル」「値」 >「セル」にはリンク設定をして、ジャンプするようにしたいのです。ハイパーリンクでは飛びませんから、非常に特殊なマクロが必要のようです。前回、マクロが抜ける質問をしていた人への回答にもなります。(no.9064013) このマクロは、検索に際して、本体のExcel を使わず、オートメーションで行っています。また、ジャンプに関しては、また、十分にテストを行っていません。数式に対してダブルクリックをすると、そちらに飛ぶようになっています。検索よりも遥かに難しかったです。(No.2) 最終的には、UserFormを使うことを考えています。最終的には、UserFormに取り付けて、アドイン型がよいのではないかとも思います。最終段階では、COMで、検索したほうがよいかもしれません。現在は、オートメーション型になっています。言い換えれば、Excelは使っているけれども、別のExcelを使って検索しますから、ファイルの必要な部分しかオープンしていません。現在のスタイルは、何もないシートひとつ必要となります。私は、集中力もなく、頭もボケているというか、霞がかった状態ですが、なんとか、形になりましたので、ご披露させていただきました。コードは、次の書き込みにします。 '//標準モジュール Public ShName As String　'本来は、JampMacroの引数 Public CellAdd As String　'本来は、JampMacroの引数 Const FileHead As String = ""　'ファイルの先頭 Const EXT As String = "xls?" '拡張子 Sub SearchDatainFolder() 　Dim FName As String, myPath As String 　Dim tmpPath As String 　Dim serTxt As Variant 　Dim myArray 　On Error GoTo ErrHandler 　Application.EnableCancelKey = xlErrorHandler　'ハングした時の用心のため　'アクティブシートとして空のシートを用意してください。　If MsgBox("一旦全部シート上の情報は削除されます。" & _ 　　 vbCrLf & "バックアップを取るなら、一旦中止してください。", vbExclamation + vbOKCancel) = vbCancel Then 　　 Exit Sub 　End If 　ActiveSheet.Cells.Clear 　ReDim myArray(2000) 　serTxt = Application.InputBox("検索語を入力してください。", "検索語入力", Type:=2) 　If serTxt = "False" Or Trim(serTxt) = "" Then Exit Sub 　With Application.FileDialog(msoFileDialogFolderPicker) 　　If .Show = True Then 　　　myPath = .SelectedItems(1) & "\" 　　End If 　End With 　If myPath = "" Then Exit Sub 　FName = Dir(myPath & FileHead & "*." & EXT, vbNormal) 'Excelファイル限定　Do While FName <> "" 　　If FName <> "." And FName <> ".." Then 　　　If (GetAttr(myPath & FName) And vbNormal) = vbNormal Then 　　　　myArray(i) = FName 　　　　i = i + 1 　　　　If i > 2000 Then Exit Sub 　　　End If 　　End If 　　FName = Dir 　Loop 　If i = 0 Then 　　MsgBox "目的のExcelファイルはありませんでした。", vbExclamation 　　Exit Sub 　End If 　ReDim Preserve myArray(i - 1) 　If i > 100 Then 　　If MsgBox("ファイルが100個以上(" & i & ")ありますが、続けますか？", vbOKCancel) = vbCancel Then 　　　Exit Sub 　　End If 　End If 　Dim c As Range 　Dim FirstAddress As String 　Dim objXl As Object 　Dim j As Long: j = 2 　　Cells(1, 1).Value = serTxt 　Set objXl = CreateObject("Excel.Application") 　　 For i = 0 To UBound(myArray) 　 With objXl.Workbooks.Open(Filename:=myPath & myArray(i), ReadOnly:=True) 　　For Each sh In .Worksheets 　　DoEvents 　　Set c = sh.Cells.Find( _ 　　 What:=serTxt, _ 　　 LookIn:=xlValues, _ 　　 LookAt:=xlPart, _ 　　 MatchCase:=False, _ 　　 MatchByte:=False) 　　　　 If Not c Is Nothing Then 　　　　　FirstAddress = sh.Name & "!" & c.Address 　　　　　　Do 　　　　　　Set c = sh.Cells.FindNext(c) 　　　　　　With ActiveSheet　'現行ではアクティブシート'以下は適当に　　　　　　.Cells(j, 1).Value = myPath 　　　　　　.Cells(j, 2).Value = myArray(i) 　　　　　　.Cells(j, 3).Value = sh.Name 　　　　　　.Cells(j, 4).Value = c.Address(0, 0) 　　　　　　.Cells(j, 5).Value = "='" & myPath & "[" & myArray(i) & "]" & sh.Name & "'!" & c.Address(0, 0) 　　　　　　End With 　　　　　　j = j + 1 　　　　 If sh.Name & "!" & c.Address = FirstAddress Then Exit Sub 　　　　　Loop Until c Is Nothing 　　　　 End If 　　Next 　 .Close False 　 End With 　 Next i 　 If j = 0 Then 　　 MsgBox serTxt & "は見つかりませんでした。", vbExclamation 　 End If ErrHandler: 　Set objXl = Nothing 　Application.EnableCancelKey = xlInterrupt 　MsgBox "終了!" End Sub 'ジャンプマクロ(シートのイベント・ドリブン型マクロと組み合わせ） Public Sub JumpMacro() 'ByVal ShName As String, ByVal CellAdd As String) 　Application.Goto ActiveWorkbook.Worksheets(ShName).Range(CellAdd) End Sub