エクセルでの検索が遅い

Question

お世話になります。
A〜N列に計算式など含まない300行ほどのデータのあるエクセルブックが毎日
指定したフォルダ内に出力されます。（ファイル名はyyyymmdd形式／シートは1枚／項目名など同一）
この複数ファイルデータを串刺しで検索できるようにしたく、
https://ameblo.jp/u-kun-win/entry-12009677339.html
にあるVBAを使い半年分のデータでテストしたのですがフリーズしたかと思うほど時間がかかります。
(コードは以下）
---
Sub Auto_Open()


Dim WS As Worksheet
Dim myfolder As String
Dim Str As String
Dim a As Single
Dim sht As Worksheet

Set WS = Sheets.Add

    myfolder = "C:\Users\〜ファイルのあるパス\"
    

Str = Application.InputBox(prompt:="検索文字列:", Title:="フォルダにある全Excelファイルを検索します", Type:=2)

If Str = "False" Then Exit Sub
If Str = "" Then Exit Sub

WS.Range("A1") = "検索文字列:"
WS.Range("B1") = Str
WS.Range("A2") = "パス:"
WS.Range("B2") = myfolder
WS.Range("A3") = "ファイル名"
WS.Range("B3") = "シート名"
WS.Range("C3") = "セル"
WS.Range("D3") = "リンク"
WS.Range("E3") = "セル内の文字列"

a = 0
               
Application.ScreenUpdating = False

Value = Dir(myfolder)
Do Until Value = ""
    If Value = "." Or Value = ".." Then
    Else
        If Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm" Then
            On Error Resume Next
            Workbooks.Open Filename:=myfolder & Value, Password:="zzzzzzzzzzzz"
            If Err.Number > 0 Then
                WS.Range("A4").Offset(a, 0).Value = Value
                WS.Range("B4").Offset(a, 0).Value = "Password protected"
                a = a + 1
            Else
                On Error GoTo 0
                For Each sht In ActiveWorkbook.Worksheets

'セルの文字列に完全マッチしたいならxlWholeを使う。部分マッチしたいならxlPartを使う。
'                        Set c = sht.Cells.Find(Str, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
                        Set c = sht.Cells.Find(Str, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
                        If Not c Is Nothing Then
                            firstAddress = c.Address
                            Do
                                WS.Range("A4").Offset(a, 0).Value = Value
                                WS.Range("B4").Offset(a, 0).Value = sht.Name
                                WS.Range("C4").Offset(a, 0).Value = c.Address
                                WS.Hyperlinks.Add Anchor:=WS.Range("D4").Offset(a, 0), Address:=myfolder & Value, SubAddress:= _
                                sht.Name & "!" & c.Address, TextToDisplay:="Link"
                                WS.Range("E4").Offset(a, 0).Value = c.Value
                                a = a + 1
                                Set c = sht.Cells.FindNext(c)
                            Loop While Not c Is Nothing And c.Address <> firstAddress
                        End If
                Next sht
            End If
            Workbooks(Value).Close False
            On Error GoTo 0
        End If
    End If
    Value = Dir
Loop

Application.ScreenUpdating = True

Cells.EntireColumn.AutoFit

End Sub
------

ならばとデータを1つのブックの1つのシートにまとめて普通に検索してみたところ
ファイルサイズが大きくなる為ファイルを開くのにも数秒かかるようになり、
検索にかかる時間も30秒以上かかってしまいます。

そこで、上のURLのVBAを手直しして
データは日付ごとのファイルのまま、検索する範囲をフォルダ内のファイル全てではなく
「過去〜ヶ月」と指定できればよいのではないかなどと考えていますが、
VBAをどういじったら良いかよくわかりません。
別シートにDir関数でフォルダ内のファイルリストを作って何行目まで開くか指定するとかなのか・・な？
それとも軽くするために全く違うアプローチがあるのかもしれませんが・・
すみません、分かる方、教えてください。
宜しくお願いします。

WindFaller · Accepted Answer

With sh2
        If .Cells(1, 1).Value = "" Then
            .Cells(1, 1).Value = "検索値"
            .Cells(2, 1).Value = "検索フォルダー"
            .Cells(3, 1).Value = "検索結果"
            .Cells(1, 2).Value = Ret
            .Cells(2, 2).Value = myFolder
        End If
        .UsedRange.Offset(3).ClearFormats
        .UsedRange.Offset(3).ClearContents
        If i > 0 Then
            For j = 0 To i - 1
                sh2.Hyperlinks.Add .Cells(j + 4, 1), myFolder & Ar(j, 0), _
                                   Ar(j, 1) & "!" & Ar(j, 2), "", Ar(j, 0) & "." & Ar(j, 1) & "!" & Ar(j, 2)

arTmp = Ar(j, 3)
                On Error Resume Next
                y = UBound(arTmp)
                If Err.Number <> 0 Then
                    y = 1　'たぷん不要
                End If
                .Cells(j + 4, 3).Resize(, y).Value = arTmp
                On Error GoTo 0
            Next j
            MsgBox i & "個 見つかりました。", vbInformation
            .Select
        Else
            MsgBox "検索値は見つかりませんでした。", vbExclamation
        End If
    End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Set sh1 = Nothing
    Set sh2 = Nothing
    Set wb = Nothing
End Sub
'//

返事を書けずに、すみません。
>#6の補足で変数Arについて聞いたのですが、自己解決しました。配列だったんですね。
配列を使うというのは、不要なメモリ=オブジェクトを持ち越さなくても済むので、ある程度のサイズでは、高速にデータを移動させることが可能なのです。リミットが、60,000ぐらいだっと思います。

>「検索にかかったセルの箇所の行全てのデータを一覧シート」
問題は、ここなのです。この全体のパターンを使う時には、すでに、ある方法が頭の中にあったのですが、それが妥当かどうかは、分からないのです。ただ、EntireRow というのは、お世辞にもうまくありません。掲示板のある程度の経験者ですと、
　Intersect(r.EntireRow, sh.UsedRange).Copy  目的セル
という手法が使われます。

しかし、私は、それは少しぬるい方法だと思っています。オブジェクトをコピー＆ペーストをしていたら、タイムロスが生じてしまいます。そこで、配列を再び使うという方法を考えます。ただし、それは、特殊な方法で、Range を、１次元配列に直すことです。

なお、#8様のテキスト化については、仮想空間で、テキスト化させて、串刺し検索をさせる方法があります。xdoc2txt というツールを利用します。これは商用利用されている無償のツールでもあります。

http://ebstudio.info/home/xdoc2txt.html
ただし、完全なテキスト化ですから、セルの行自体を再現させることは困難です。

WindFaller · Answer

あくまでも、配列は配列にこだわってみました。

Ar配列変数に1行データを入れてしまうことにしました。

シート1に、リスト
シート2に、結果が出るようになっています。ただし、書式などは入っておりません。
copy のスタイルが良ければ、また書き換えます。

'//
Sub prfFind_Words2()
Dim wb As Workbook
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim Ret As String 'Valueは変数には使わない。Ret は、Returnの意味
Dim i As Long, j As Long
Dim fn As Variant
Dim c As Variant
Dim FirstAddress As String
Dim Ar(2000, 3)
Dim myFolder As String
Dim fns As Variant
Dim arFn As Variant '配列でのファイル格納
Dim Target As Range
Dim fndRng As Range
Dim arTmp As Variant
Dim x As Long, y As Long

Set sh1 = ThisWorkbook.ActiveSheet
On Error Resume Next
Set sh2 = ThisWorkbook.ActiveSheet.Next
If Err.Number <> 0 Then
MsgBox "出力シートを設定してください。", vbCritical
Exit Sub
End If
On Error GoTo 0

With sh1
If TypeName(Selection) <> "Range" Then Exit Sub
Set Target = Selection
If Target.Cells(1).Column <> 2 Or Target.Cells(1).Row < 4 Then
MsgBox "ファイル名を選択してください。", vbExclamation
Exit Sub
End If

For Each c In Target
fns = fns & "," & c.Value
Next c
fns = Mid(fns, 2)
If fns = "" Then Exit Sub
arFn = Split(fns, ",")
myFolder = .Range("B2").Value
If Dir(myFolder, vbDirectory) = "" Then MsgBox "B2 に、適正なフォルダーがシート上にはありません。", vbExclamation: Exit Sub
If Right(myFolder, 1) <> "\" Then myFolder = myFolder & "\"
End With
If sh1.Cells(1, 1).Value = "" Then
sh1.Cells(1, 1).Value = "検索値"
End If
Ret = sh1.Cells(1, 2).Value
If Ret = "" Then
MsgBox "検索値を入力してください。", vbExclamation
Application.Goto sh1.Cells(1, 2)
End If
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For Each fn In arFn
Set wb = Workbooks.Open(myFolder & fn)
If Not wb Is Nothing Then
''x検索値 Ret にワイルドカードを入れる
With wb.Worksheets(1)
Set c = .UsedRange.Find("*" & Ret & "*", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
Application.StatusBar = wb.Name
If Not c Is Nothing Then
FirstAddress = c.Address
Do
Ar(i, 0) = wb.Name
Ar(i, 1) = wb.Worksheets(1).Name
Ar(i, 2) = c.Address

x = .Cells(c.Row, Columns.Count).End(xlToLeft).Column
If x > 1 Then
arTmp = .Cells(c.Row, 1).Resize(, x).Value
Ar(i, 3) = Application.Index(arTmp, 1, 0)
Else
Ar(i, 3) = Array(c.Value, "")
End If
DoEvents
i = i + 1
If i > 2000 Then Exit Do
Set c = wb.Worksheets(1).UsedRange.FindNext(c)
DoEvents
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
wb.Close False
Application.StatusBar = False
On Error GoTo 0
End If
Next fn
'---続き－－

ママチャリ · Answer

横から失礼します（お邪魔するつもりはありません。これっきりと云うことでお許しください）。

「Excelブックが毎日格納される」と云うことですが、それと同時にCSV変換したファイルを保存することはできないでしょうか？テキストファイルであれば、findstrコマンドなどを使って、高速な検索ができる上に、ヒットした行を出力してくれるので、その出力をシートに展開するだけで、目的が達成できると思います。
「ひとつのブックに纏める」のような運用が候補に上がっているので、「CSVファイル化も可能では」と考えた次第です。

WindFaller · Answer

#6の解説を少し入れておきます。

最初の掲載のマクロをモデルに、私のやり方でユーティリティを作ってみました。速度について考慮して作ったわけではありませんが、コンセプトは省労力というところでしょうか。
リスト作成は、増えたら追加といきたいのですが、ミッシングファイルもありますので、単純にはいかず、ちょっと知恵をひねらないとできません。量が大量でなければ、最初から取得してしまったほうが早そうです。

本来は、ハイパーリンクの代わりに、ダブルクリツク・イベントを付ける予定にしていましたが、コードが長くなりすぎるので、それは取りやめました。

InputBox を使わずに検索値は「B1」に、そして、フォルダーは、「B2」に書くことにしました。
本来は、ここにActiveX コントロールのTextBox などを置くと、その入力のイベントでマクロの起動になるのですが、フォームコントロール・ボタンのほうが安全に、また、移動も楽です。

フォームコントロール・ボタンで、リストを作り、本来は、チェックボックスを設けるのですが、それも煩雑になりますので、省略して、マウスの選択で、そのファイルの中を検索させることにしました。このコードの変わったところは、ファイルをすでに開いていても、エラーにならず、検索するところです。

なお、私のレイアウトのまずさは、私が最初に表計算を使い始めた時以来なので、それはご勘弁ください。

WindFaller · Answer

仕上がりのイメージは、添付画像を見てください。解説は文字制限ため後ほど '------------------ 'フォームコントロール・ボタン1 MakingList 'フォームコントロール・ボタン2 prfFind_Words ''標準モジュール '----------------------- Sub MakingList() 'リスト表作成 Dim myFolder As String Dim LastRow As Long Dim fn As String Dim myArray(3000) Dim i As Long, j As Long, k As Long Dim Rng As Range myFolder = Range("B2").Value If myFolder = "" Or Dir(myFolder, vbDirectory) = "" Then MsgBox "B2に、検索対象フォルダーを入れてください。", vbExclamation Exit Sub End If LastRow = Cells(Rows.Count, 2).End(xlUp).Row If LastRow > 4 Then MsgBox "ファイル名と結果を削除します。" Range("B4", Cells(LastRow, "D")).ClearContents End If If Right(myFolder, 1) <> "\" Then myFolder = myFolder & "\" fn = Dir(myFolder & "?*.xls?", vbNormal) Do While fn <> "" 　If fn <> "." And fn <> ".." Then 　　　myArray(i) = fn 　　　i = i + 1 　　　If i > 3000 Then Exit Sub 　End If 　fn = Dir Loop Range("B3").Value = "ファイル名": Range("D3").Value = " 結果" Set Rng = Range("A4", Cells(Rows.Count, 1).End(xlUp)) 　Cells(2, 1).Value = "検索フォルダー": Cells(2, 2).Value = myFolder For j = 0 To i 　 Cells(j + 4, 2).Value = myArray(j) Next End Sub '// Sub prfFind_Words() 　Dim wb As Workbook 　Dim sh As Worksheet 　Dim Ret As String 　Dim i As Long, j As Long 　Dim st As Long '結果を出力する最初の行　Dim LastRow As Long 　Dim fn As Variant 　Dim c As Variant 　Dim FirstAddress As String 　Dim Ar(2000, 2) 　Dim myFolder As String 　Dim fns As Variant 　Dim arFn As Variant '配列でのファイル格納　Dim Target As Range 　'' シートを加えるのは取りやめ　Set sh = ThisWorkbook.ActiveSheet 　With sh 　　LastRow = .Cells(Rows.Count, "D").End(xlUp).Row 　　st = 4 　　If LastRow > 3 Then 　　 If MsgBox("検索結果を削除してよろしいですか?", vbOKCancel) = vbOK Then 　　 .Range("D4", .Cells(LastRow, "D")).ClearContents 　　 Else 　　 st = LastRow + 1 　　 End If 　　End If 　　If TypeName(Selection) <> "Range" Then Exit Sub 　　Set Target = Selection 　　If Target.Cells(1).Column <> 2 Or Target.Cells(1).Row < 4 Then 　　　MsgBox "ファイル(複数可）をB列より選択してください｡ ", vbExclamation 　　　Exit Sub 　　End If 　　For Each c In Target 　　　fns = fns & "," & c.Value 　　Next c 　　fns = Mid(fns, 2) 　　If fns = "" Then Exit Sub 　　arFn = Split(fns, ",") 　　myFolder = .Range("B2").Value 　　If Dir(myFolder, vbDirectory) = "" Then MsgBox "B2 に、適正なフォルダーがシート上にはありません。", vbExclamation: Exit Sub 　　If Right(myFolder, 1) <> "\" Then myFolder = myFolder & "\" 　End With 　'Ret = Application.InputBox(Prompt:="検索文字列:", Title:="フォルダにある全Excelファイルを検索します", Type:=2) 　sh.Cells(1, 1).Value = "検索値": Ret = sh.Cells(1, 2).Value 　If Ret = "" Then 　 MsgBox "B1に検索値を入れてください。", vbExclamation 　 Exit Sub 　End If 　Application.Calculation = xlCalculationManual 　Application.ScreenUpdating = False 　For Each fn In arFn 　　On Error Resume Next 　　'二重に開くコードを回避　　Set wb = GetObject(myFolder & fn) 　　 If wb Is Nothing Then 　　Set wb = Workbooks.Open(myFolder & fn) 　　End If 　　If Not wb Is Nothing Then 　　　''x検索値 Ret にワイルドカードを入れる　　　Set c = wb.Worksheets(1).UsedRange.Find("*" & Ret & "*", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext) 　　　Application.StatusBar = wb.Name 　　　If Not c Is Nothing Then 　　　　FirstAddress = c.Address 　　　　Do 　　　　　Ar(i, 0) = wb.Name 　　　　　Ar(i, 1) = wb.Worksheets(1).Name 　　　　　Ar(i, 2) = c.Address 　　　　　DoEvents 　　　　　i = i + 1 　　　　　If i > 2000 Then Exit Do 　　　　　Set c = wb.Worksheets(1).UsedRange.FindNext(c) 　　　　　DoEvents 　　　　Loop While Not c Is Nothing And c.Address <> FirstAddress 　　　End If 　　　wb.Close False 　　　Application.StatusBar = False 　　　On Error GoTo 0 　　End If 　Next fn 　With sh 　　.Cells(2, 1).Value = "検索フォルダー": .Cells(2, 2).Value = myFolder 　　If i > 0 Then 　　　For j = 0 To i - 1 　　　　ActiveSheet.Hyperlinks.Add .Cells(j + st, 4), myFolder & Ar(j, 0), _ 　　　　　　　　　　 Ar(j, 1) & "!" & Ar(j, 2), "", Ar(j, 0) & "." & Ar(j, 1) & "!" & Ar(j, 2) 　　　Next j 　　　MsgBox i & "個見つかりました。", vbInformation 　　Else 　　　MsgBox "検索値は見つかりませんでした。", vbExclamation 　　End If 　End With 　Application.ScreenUpdating = True 　Application.Calculation = xlCalculationAutomatic 　Set sh = Nothing 　Set wb = Nothing End Sub

WindFaller · Answer

最初に、仕様に関わっている問題の解決方法というのは、極めて難しいものですが、特殊なアルゴリズムもやり方によっては可能かもしれません。使うかどうかは、まだ検討の段階には入れていません。

Find メソッドというのは、きわめてオーソドックスな検索方法ですが、いわゆるデータベース的な検索方法とは違う、Excel独特のものなのです。私は、Find検索をあまり芳しいとは思わない理由として、検索場所を特定しないからなのです。私などは、よく一意のものを探すのに、Match関数を１次元で使うという方法を使います。ただし、データ量の上限があります。

そこで質問です。
・1ブックにシートは多数あるのですか。

・プロテクトされたブックは予め除外できないか。
　言い換えれば、多くの現代のファイル検索ソフトは、最初にリスト表を作り上げてあって、そこから対象ファイルを限定して、検索する方法が取られていることが多いです。新規に加わったブッは、新たに追加しています。

・わざわざハイパーリンクを作っているようですが、そのハイパーリンクは、そもそもなんのためにあるのでしょうか。開くためというよりも、その結果は溜めておくようなことはしないのですか？

・一体、何を検索しているのでしょうか？文字ですか、数値ですか？
　列は特定できないか、次に、文字列や不特定の検索語を入れて、ワークシート全体を検索するのは、遅くなるのは当然で、データベースでは到底ムリな検索方法です。そのためのツールというものは、別途あります。
xdoc2txt は、単独では使えません。プログラムに組み合わせて使うものです。
http://ebstudio.info/home/xdoc2txt.html

実際には表もファイルも見ていませんので、成功する確率は低いのですが、一つ例をあげます。
－－－－－－－－－－－－－－
私は、ここの掲示板の半月分のタイトル・日付・ハンドルのリストをExcelに作ってあります。以前は、1年以上も溜めていたのですが、管理が面倒なのでやめました。

そのリストの1行

受付中　　2018/04/01 21:16　　エクセルでの検索が遅い　　4　hidka　　0402810　　1
4は発言数。最後の1は、私が発言した記録

ここのサイトにブラウザで開ける前に、どこか決めて、どんな質問か、何を自分は発言し、何を発言しようとしているのかデータを蓄えていて、そこで、ブラウザを開けないままに、今、どんな返事が来ているかを調べて、エディタに書き加えて、そこで、実際にブラウザでアクセスして、アップロードしています。

>ファイルは日付で並んでいるので
>1、マクロ実行
>2、何日分を（いくつのファイルを）串刺し検索するかinputboxに入力してOKボタン

ファイル名が日付でつけられているのならともかく、オブジェクトを作ってそこから選び出すというのは、根本的な解決にはならないように思います。

思い当たる常識的な対処法は、すでに提示しました。それで解決しないから、そのまま、今のマクロに手を加えて直るという段階ではないように思うのです。もう少し、事前の段階での処理を加える必要があるのではないかと考えています。

最後に、お陰様でやっと、この機に、エディタの整形マクロの方が直りましたので、一言書かせていただきます。

WindFaller · Answer

#3 の回答者です。
こちらのコードで、明らかな間違いがでるのは、新しく購入したエディタの整形マクロがまだうまくいっていないということで、エディター用のマクロまでは追い付かないです。お見苦しいところはすみません。

それで、根本的な実行スピードの遅さという問題ですが、どうやら、別の要因があるようです。
私が今回試みた趣旨は、要するにマクロ実行にまつわるオブジェクトを溜めていくことを避けるということが趣旨ですが、結果は思うようにならなかった、つまり、そこではない、ということでしょう。
>それからハイパーリンクが貼られないです。
これは、レイアウトの問題でしょうから、それは修正はできますが、むしろ、ハイパーリンクを別にした理由も、オブジェクトの累積だったのですから、これも違うということでしょう。

そうすると、後は、まったく別な要因を探したほうがよいのではないかと思います。
もちろん、私は、#2さんの示されたものの、私のは、それ以前のものですから、たぶんオリジナルツールだと思いますが、別の検索方法をマクロで作ったことはありますが、単なる串刺し検索ですから、早いことは早いですが、あるなしを調べるだけのもので、今回のものには該当しないように思っています。

後の要因として考えられるのは、
アドイン・COMアドイン　(外す)
セキュリティツールの原因　(除外アイテムに入れるとか？)
マイクロソフトのOfficeのアップデート　(特定のPCに適用されるそうです)
インターネット・キャッシュ、　(削除)
オプティマイゼーション（再配置）

Excel のファイルに数式が多数置かれている、(マクロに、Application.Calculation =False を使う)
それから最も問題になるのは、
Excel のハングアップした後の残骸。(:\Users\[UserID]\AppData\Local\Microsoft\Office あたりにあるはず)
仮想空間のスペースが小さすぎる（メモリ設定を修正？今は変わったかもしれしません。）

ひとつだけ忘れていましたが、
Worksheets(1).Cells を、UsedRange に変える

他にも、VBEエディター上に、ワークシートで使う関数式(ワークシート関数を使うのではなく、文字列の数式)を置くことが、メモリの累積を招く原因になりますから、これは気を付けたほうがよいです。もともと、VBEとワークシートは、表裏一体ではなく、インターフェースでつながれていますから、そこに数式を置きますと、セルとひも付き状態になるようです。

手っ取り早い話としては、PCを変えても同じ結果か、ということですね。

WindFaller · Answer

こんにちは。試しに書き換えてみました。オブジェクトを蓄積していく部分を極力排除しました。また、ハイパーリンクは、ループの途中ではやらずに、後でまとめてすることにしました。 '// Sub Find_Words() 　'Auto_Open は辞めました。　Dim ws As Worksheet 　Dim myFolder As String 　Dim wb As Workbook 　Dim Ret As Strin　'Valueは変数には使わない。Ret は、Returnの意味　'Dim a As Single 　Dim i As Long 　Dim fn As String 　Dim c As Variant 　Dim sht As Worksheet 　Dim FirstAddress As String 　Set ws = ThisWorkbook.Worksheets.Add 　　myFolder = Application.DefaultFilePath 　'デフォルトパス　If Right(myFolder, 1) <> "\" Then myFolder = myFolder & "\" 　　myFolder = myFolder & "TestFolder" 　If Right(myFolder, 1) <> "\" Then myFolder = myFolder & "\" 　Ret = Application.InputBox(Prompt:="検索文字列:", Title:="フォルダにある全Excelファイルを検索します", Type:=2) 　If Ret = "False" Then Exit Sub 　If Ret = "" Then Exit Sub 　With ws 　　 .Range("A1").Value = "検索文字列:" 　　 .Range("B1").Value = Ret 　　 .Range("A2").Value = "パス:" 　　 .Range("B2").Value = myFolder 　　 .Range("A3").Value = "ファイル名" 　　 .Range("B3").Value = "シート名" 　　 .Range("C3").Value = "セル" 　　 .Range("D3").Value = "リンク" 　　 .Range("E3").Value = "セル内の文字列" 　End With 　i = 4 　Application.ScreenUpdating = False 　fn = Dir(myFolder & "?*.xls?"　'excel の拡張子3つ　Do Until fn = "" 　　 If fn <> "." Or fn <> ".." Then 　　　 On Error Resume Next 　　　 'オブジェクトを取る　　　 Set wb = Workbooks.Open(Filename:=myFolder & fn, Password:="""") 　　　 If wb Is Nothing Then 　　　　　ws.Cells(i, 1).Value = fn 　　　　　ws.Cells(i, 2).Value = "Password protected" 　　　　　i = i + 1 　　　 Else 　　　　　For Each sht In wb.Worksheets 　　　　　　 ''x検索値 Ret にワイルドカードを入れる　　　　　　 Set c = sht.Cells.Find("*" & Ret & "*", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext) 　　　　　　 If Not c Is Nothing Then 　　　　　　　 FirstAddress = c.Address 　　　　　　　 Do 　　　　　　　　　ws.Cells(i, 1).Value = fn 　　　　　　　　　ws.Cells(i, 2).Value = sht.Name 　　　　　　　　　ws.Cells(i, 3).Value = c.Address 　　　　　　　　　ws.Cells(i, 4).Value = sht.Name & "!" & c.Addres　 '' myFolder & fn 　　　　　　　　　' 　　　　　　　　　ws.Cells(i, 5).Value = c.Value 　　　　　　　　　i = i + 1 　　　　　　　　　Set c = sht.Cells.FindNext(c) 　　　　　　　　　DoEvents 　　　　　　　 Loop While Not c Is Nothing And c.Address <> FirstAddress 　　　　　　 End If 　　　　　Next sht 　　　　　wb.Close False 　　　　　Set wb = Nothin　'一旦オブジェクトを開放する　　　　　On Error GoTo 0 　　　 End If 　　 End If 　　 fn = Dir 　Loop 　Application.ScreenUpdating = True 　Call SetHyperlinks(myFolder) 　 ws.Cells.EntireColumn.AutoFit End Sub Sub SetHyperlinks(ByVal myFolder As String) 'ハイパーリンクをつける　Dim i As Long 　Dim sh As Worksheet 　Dim TargetAdr As String 　　　Set sh = ActiveSheet 　With sh 　　 For i = 4 To .Cells(Rows.Count, 4).End(xlUp).Row 　　　 On Error Resume Next 　　　 .Cells(i, 4).Hyperlinks(1).Delete 　　　 On Error GoTo 0 　　　　　　 .Hyperlinks.Add Anchor:=.Cells(i, 4), _ 　　　　　　　 Address:=myFolder & .Cells(i, 1).Value, _ 　　　　　　　 SubAddress:=.Cells(i, 2).Value & "!" & .Cells(i, 3).Value, _ 　　　　　　　 TextToDisplay:="Link" 　　　 Next i 　End With End Sub

あらっそ · Answer

こんな記事もありました

http://cryingsun-system.com/excel/excelgrep.html

あらっそ · Answer

検索対象となるファイルだけ、別フォルダーに入れてあげればよいのでは？

エクセルでの検索が遅い

With sh2

あくまでも、配列は配列にこだわってみました。

横から失礼します（お邪魔するつもりはありません。

#6の解説を少し入れておきます。

仕上がりのイメージは、添付画像を見てください。

最初に、仕様に関わっている問題の解決方法というのは、極めて難しいものですが、特殊なアルゴリズムもやり方によっては可能かもしれません。

#3 の回答者です。

こんにちは。

こんな記事もありました

検索対象となるファイルだけ、別フォルダーに入れてあげればよいのでは？

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング