[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数ファイル内検索マクロでの、行コピーとサブフォルダの検索』（k-pon）
いつもお世話になっております。
お忙しい中大変恐縮ですが、１点ご教示ください。
下記マクロを使わせて頂いております。
指定フォルダ内のexcelファイルの中身を全てキーワード検索し、
A列にファイル名、B列にシート名、C列にセル番号、D列にリンク、E列にセル内の文字列を持ってきてくれます。
これに、
（１）指定フォルダ以下の全てのサブフォルダも検索の対象にする
（２）検索でヒットしたセルを含む行全体をコピーして、F列から右にコピーする
（２）は難しいようでしたら、A列から右にコピーでも構いません。
といった機能を追加したく考えておりますが、スキル不足で手も足もでません。
ご教示をお願いしても宜しいでしょうか。
何卒、宜しくお願い申し上げます。
Sub SearchWKBooks() Dim WS As Worksheet Dim myfolder As String Dim Str As String Dim a As Single Dim sht As Worksheet
Set WS = Sheets.Add
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
myfolder = .SelectedItems(1) & "\"
End With
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
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
ちょっと、やりたいこと全部をだらだらと考えていると考えがまとまらないと思うし、
スキル不足と自分で認識しているなら、
最終結果を急いで求めるのではなく、
ここは段階を踏んで勉強するべきじゃないでしょうか？
例えば、フォルダーのパスを与えたら、
そのフォルダー内のサブフォルダーを含むすべてのエクセルファイルを、
2次元配列の変数にリストアップできる、
自作の関数を作ることは可能だろうか？
2次元配列に値があれば、繰り返しの処理は書けると思うので、
まずはその辺りにテーマを絞って勉強してみてはいかがでしょう。
（まっつわん） 2018/06/01(金) 10:50
ご指摘ありがとうございます。
そうですね。
ご助言通り、まずは順番にサブフォルダ―取得の関数作成から勉強を始めてみます。
ご教示ありがとうございました。
（k-pon） 2018/06/01(金) 13:33
この辺とか参考になると思います。
（まっつわん） 2018/06/01(金) 14:18
Functionプロシージャというのはご存知でしょうか？
返事ではよくわからないのですが、
Sub メイン()
Dim sFolderPath As String
Dim vFileList As Variant
'検索するフォルダーのパスの取得
sFolderPath = GetFolderPath()
'検索したファイルのリスト
vFileList = GetvFileList(sFolderPath)
'リストをシート上に展開
Worksheets("Sheet2").Range("A1").Resize(UBound(vFileList, 1), UBound(vFileList, 2)).Value = vFileList
End Sub
Function GetFolderPath() As String
'ここに処理を書く
End Function
Function GetvFileList(ByVal sPath As String) As Variant
'ここに処理を書く
End Function
こんな感じでFunctionプロシージャで個々の作業を別個で考えて、
メインの作業の流れに値を戻す
ように考えると考え方がすっきりすると思います。
（まっつわん） 2018/06/01(金) 14:31
何度もありがとうございます。
今、Dirの使い方や再帰処理の考え方などを調査勉強中です。
頂いたURLも参考にさせて頂きます。
Functionプロシージャーも良く分かっておりませんでしたので、頂いたコードを熟読して
勉強します。
色々とご相談に乗って頂きありがとうございました。
また分からないことが出てくるかと思いますので、その際は、またご指導いただけると幸いです。
（k-pon） 2018/06/01(金) 16:03
あれから見よう見まねでコードを書き直してみまして、サブフォルダ内のファイルも対象にすることができた・・ような気がします。
ただ、どうしてもわからない点が３点出てきてしまいましたので、大変恐縮ですが、またお知恵拝借できれば幸いです。
コードは下記のとおりです。
どうしてもわからないのが、
（１） 後半のOn Error Resume Nextがないと、 「実行時エラー'1004'アプリケーション定義またはオブジェクトの定義のエラーです」が出てしまう点
（２）恐らく検索自体はできているようなのですが、同じ検索結果が４つ重複して出てしまう
（３）ファイルを読み取り専用で開いていますが、中身だけ見られればいいので、ファイルを開かず処理したい
です。
テストフォルダの構造は、C:\Work\subで、Workフォルダとsubフォルダに別々のxlsxファイルを置いています。
何度も申し訳ございません。
何卒、宜しくお願い申し上げます。
Function folderList(Optional pathName As String = "myPath", _
Optional folderValue As String) As String
If sheetName = "mySheet" Then: sheetName = ActiveSheet.Name 'シート名
'FileSystemObjectインスタンスを生成
Set objSFO = CreateObject("Scripting.FileSystemObject")
'指定フォルダのサブフォルダ内のファイル情報取得 For Each objSubFolder In objSFO.GetFolder(pathName).subfolders
folderValue = folderValue & "," & objSubFolder.Path
Call folderList(objSubFolder.Path, folderValue) '再帰呼び出し
Next
folderList = folderValue
End Function
Function fileNameAllF(Optional pathName As String = "myPath") As Variant()
Dim fileValue() As Variant
Dim fileCnt As Integer
If sheetName = "mySheet" Then: sheetName = ActiveSheet.Name 'シート名
strArray = Split(pathName & folderList(pathName), ",")
'FileSystemObjectインスタンスを生成
Set objSFO = CreateObject("Scripting.FileSystemObject")
'指定フォルダ内のすべてのファイル数チェック
For i = LBound(strArray) To UBound(strArray)
fileCnt = fileCnt + objSFO.GetFolder(strArray(i)).Files.Count
Next i
'要素数再セット
ReDim fileValue(fileCnt - 1, 3)
r = 0
'指定フォルダ内のすべてのファイル情報を格納
For i = LBound(strArray) To UBound(strArray)
With objSFO.GetFolder(strArray(i))
For Each objFile In .Files
If LCase(objSFO.GetExtensionName(objFile)) = "xlsx" Then
fileValue(r, 0) = objFile.Name 'ファイル名
fileValue(r, 1) = .Path & "\" & objFile.Name 'ファイルフルパス名
fileValue(r, 2) = .Path 'フォルダパス名
fileValue(r, 3) = .Name 'フォルダ名
r = r + 1
End If
Next
End With
Next i
Set objSFO = Nothing
fileNameAllF = fileValue()
End Function
Sub sample4()
Dim pathName As String Dim fileData As Variant Dim WS As Worksheet Dim myfolder As String Dim Str As String Dim a As Single Dim sht As Worksheet
Dim book As Workbook
Set WS = Sheets.Add
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
myfolder = .SelectedItems(1) & "\"
End With
Str = Application.InputBox(prompt:="検索文字列:", Title:="今指定したフォルダにある全Excelファイルを検索します", Type:=2)
If Str = "False" Then Exit Sub If Str = "" Then Exit Sub
pathName = myfolder
fileData = fileNameAllF(pathName)
a = 0 r = 2
For i = 0 To UBound(fileData)
' Cells(r, 1) = fileData(i, 0) 'ファイル名 ' Cells(r, 2) = fileData(i, 1) '絶対パス＋ファイル名 ' Cells(r, 3) = fileData(i, 2) 'パス ' Cells(r, 4) = fileData(i, 3) 'フォルダ名 ' r = r + 1
On Error Resume Next 'ここを取ると実行時エラー'1004'アプリケーション定義またはオブジェクトの定義のエラーですになる
Workbooks.Open fileName:=fileData(i, 1), Password:="zzzzzzzzzzzz", ReadOnly:=True
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
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Next sht
Next
End Sub
（k-pon） 2018/06/02(土) 10:31
＞（３）ファイルを読み取り専用で開いていますが、中身だけ見られればいいので、ファイルを開かず処理したい
ファイルというかブックだとおもいますが、シート名がわかっていればブックを開かずにセルの値を取得することはできなくはないですが、されたいことを考えるとあんまりメリットがないような気がしします。
なぜ、ブックを開きたくないのですか？
ちなみに、好みの問題なんでしょうけど、
（１）処理の対象となるブックのフルパスを「対象一覧」シートのA列に列挙する
（２）「対象一覧」に記載されるブックを1つずつ、
開く〜調べる〜検索値があれば「出力」シートに出力する〜閉じる
（３）（２）を「対象一覧」に記載されるブックの分だけ繰り返す
って感じにしたほうが、ステップ実行したときなど動きを確認しやすいように思えるんですがどうでしょうか
（もこな２） 2018/06/02(土) 14:36
ひとつ言っておきます。
とりあえず動いたところで意図した結果が得られない原因が解らなくなるだけです。
エラーが出るなら1つづつエラーが出なくなるようデバッグしましょう。
それがプログラミングです。
次に
これもエラーや意図しない結果の原因を探るのに不都合になることが多々あります。
http://officetanaka.net/excel/vba/beginner/11.htm
http://www.accessclub.jp/vba/vba_016.htm
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_200_030.html
まずはこの二つを肝に銘じてコードを見直してください。
あと、デバッグのコツをいくつか
http://www.ken3.org/vba/excel-help.html
ステップインやブレークポイントを使って1行づつ実行しながら、
ローカルウィンドウなどで（他のやり方もいろいろ検索して見つつ）変数の中身が意図したものに
なっているかチェックしてみてください。
他人にデバッグしてもらいたいなら、最低限コンパイルエラーの出ないものを
提示してください。
急に、
If sheetName = "mySheet" Then: sheetName = ActiveSheet.Name 'シート名
とSheetNameという変数が出て来てますが、
シート名が「mySheet」という名前の物でいいのかいけないのかこちらには判断できません。
こういうものを「マジックナンバー」と呼びます。
プログラムには出来るだけこういうものが出てこないように書くことが肝要です。
もちろんシート名を意図した名前に限定して作業をしたいときには、
マジックナンバーになるんですが、そういうはコメントに何かわかるように書いていただけると、
ありがたいです。
解らない用語があれば検索してみて、
それでも解らない場合は、その旨を告げて、聞いて下さい。
（まっつわん） 2018/06/02(土) 15:43
思い出しながら調べながらだから結構かかりましたねぇ＾＾；；
とりあえず、ファイルのフルパスの一覧を取得するまでを書いてみました。
こういう感じで各部分を全く別個で考えて部品化することで、
他の部分に出来るだけ影響のないようにして書いていきます。
Option Explicit
'***********************************************
'指定したフォルダー内（サブフォルダーも含む）エクセルファイルすべてを検索して、
'データを抽出し、索引を作るツール
'「File System Objyect」 を利用するので「Microsoft Scripting Runtime」を参照設定すること
'*******************************
Dim mobjFSO As FileSystemObject
Sub 複数ブックからの抽出()
Dim wsResult As Worksheet
Dim sFolderPath As String
Dim sFileList() As String
Dim sKeyWord As String
'キーワードの入力
If GetKeyWord(sKeyWord) = False Then Exit Sub
'検索するフォルダーのパスの選択
If GetFolderPath(sFolderPath) = False Then Exit Sub
'FSOの取得
Set mobjFSO = New FileSystemObject
'指定したフォルダ内（下位階層も含む）を検索したファイルのフルパスの一覧の取得
ReDim sFileList(1 To 5000)
If GetFileList(sFolderPath, sFileList) = False Then
MsgBox "注意。用意したメモリー領域を超えるファイル数がありました。", vbExclamation
End If
'結果出力用シートの用意
Set wsResult = GetResultSheet()
'リストを結果出力用シート上にテストで展開
wsResult.Range("A1").Resize(UBound(sFileList)).Value = WorksheetFunction.Transpose(sFileList)
End Sub
'**************************************************
'インプットボックスに入力したキーワードを返す関数
'引数：入力した文字列を受け取る変数（参照渡しします。）を指定してください。
'返り値：True/False（キャンセル時False)
'**************************************************
Private Function GetKeyWord(ByRef s As String) As Boolean
Dim ans As String
Do
ans = InputBox("検索文字列:", "指定するフォルダにある全Excelファイルを検索します")
If StrPtr(ans) = 0 Then Exit Function
Loop Until Len(ans) > 0
s = ans
GetKeyWord = True
End Function
'***********************************************************
'フォルダーを選択し、選択をしたフォルダーのパスを返す関数
'引数:フォルダーのパスを受け取る変数を指定（参照渡しします。）を指定してください。
'返り値：True/False（キャンセル時False)
'***********************************************************
Function GetFolderPath(ByRef s As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = "D:\user"
.AllowMultiSelect = False
.Title = "フォルダの選択"
If .Show Then
s = .SelectedItems(1)
GetFolderPath = True
End If
End With
End Function
'*************************************************************
'指定したフォルダー内の（サブフォルダーを含む）エクセルファイルのフルパスの一覧を返す関数
'第一引数：フォルダーのパスを示す文字列
'リストを保持する変数（参照渡し）を指定してください。
'返り値：ファイルのフルパスを示す文字列の一覧（1次配列）
'*************************************************************
Private Function GetFileList(ByVal sFolderPath As String, _
ByRef psFilesList() As String, _
Optional ByRef ix As Long = 0, _
Optional flg As Boolean = True) As Boolean
Dim oFile As File
Dim oFolder As Folder
Dim oSubFolder As Folder
Dim i As Long
If mobjFSO.FolderExists(sFolderPath) = False Then Exit Function
Set oFolder = mobjFSO.GetFolder(sFolderPath)
For Each oSubFolder In oFolder.SubFolders
If GetFileList(oSubFolder, psFilesList, ix, False) = False Then GoTo ErrH
Next
For Each oFile In oFolder.Files
ix = ix + 1
If ix > UBound(psFilesList) Then GoTo ErrH
psFilesList(ix) = oFile.Path
Next
GetFileList = True
If flg Then ReDim Preserve psFilesList(1 To ix)
Exit Function
ErrH:
GetFileList = False
End Function
'*************************************************
'自ブックからコピーして新しいブックにした結果を書き込むシートを返す関数
'引数:なし
'返り値：新しいブックのシート
'**************************************************
Private Function GetResultSheet() As Worksheet
ThisWorkbook.Worksheets(1).Copy
Set GetResultSheet = Workbooks(Workbooks.Count).Worksheets(1)
GetResultSheet.UsedRange.Clear
End Function
'************<プログラム終わり>**************
一個気づいた点を指摘すると、
> 'FileSystemObjectインスタンスを生成
> Set objSFO = CreateObject("Scripting.FileSystemObject")
k-ponさんのコードでは再帰呼び出しするたびにインスタンスを生成してますが、
プロジェクトの中で、1つあれば十分なので、変数の適用範囲をモジュールレベルで適用させることで、
なんどもインスタンスの生成をすることを避けられます。
100くらいならどうでもいいかも知れんけど、何千何万となるとなんか不都合が出てきそうな気がして
気持ち悪いです。
ぼくも参考にしたサイトにもそんな書き方がしてあったけど、
あんまり真似したくないなと思いました。ただし、どっちが正解かは僕にはわからないので＾＾；
興味があれば、別途質問されるといいと思います。
もう少しなんで検索部分も考えてみます。けど、とりあえずご飯行ってきます。
（まっつわん） 2018/06/02(土) 18:22
Dim cnt As Long '←モジュールレベルで宣言
Private Sub ファイル一覧作成()
cnt = 0 '←モジュールレベル変数「cnt」を初期化
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then Exit Sub
Workbooks("まくろ.xlsm").Worksheets("ブック一覧").Cells.Clear
Call サブルーチン(.SelectedItems(1))
End With
End Sub
Sub サブルーチン(パス As String)
Dim フォルダ As Object, ファイル As Object
Dim dstSH As Worksheet
Set dstSH = Workbooks("まくろ.xlsm").Worksheets("ブック一覧")
With CreateObject("Scripting.FileSystemObject").GetFolder(パス)
'ファイルの検索
For Each ファイル In .Files
If ファイル.Name Like "*.xls?" Then
cnt = cnt + 1
dstSH.Cells(cnt, "B").Value = ファイル.Name
dstSH.Cells(cnt, "A").Value = ファイル.Path
End If
Next ファイル
'サブフォルダの検索
For Each フォルダ In .SubFolders
'サブフォルダがあれば、サブフォルダのパスを引数にして再帰呼出
Call サブルーチン(フォルダ.Path)
Next フォルダ
End With
End Sub
何度もありがとうございます。
本当に基礎の基礎が分かっていないことが再確認できました。
ステップインの使い方も何となくでしか分かっていませんでしたので、この機会にちゃんと勉強します。
型宣言の件はお恥ずかしい限りです。
途中で頭がこんがらがってしまい、このような結果になってしまいました。
マジックナンバー（今回初めて知った用語です）につきましても、ご指摘のとおりです。
On Error Resume Nextはやはり良くなかったのですね・・・
解らない用語があれば検索してみて、 それでも解らない場合は、その旨を告げて、聞いて下さい。
かしこまりました。
少し慌て過ぎていた感がありますので、今度こそ、きちんと勉強してからご質問させていただきます。
なんどもインスタンスの生成をすることを避けられます。
この辺りも全く気づきませんでした。ご指摘ありがとうございます。
もう少しなんで検索部分も考えてみます。けど、とりあえずご飯行ってきます。
お忙しい中、お手数をおかけし申し訳ございません。m(__)m
ぼくも参考にしたサイトにもそんな書き方がしてあったけど、 あんまり真似したくないなと思いました。ただし、どっちが正解かは僕にはわからないので＾＾；
もしかすると同じサイトだったかもしれません。
よく理解もせず使ってしまった点は流石に反省しています。
ふー。2時間チョイかぁ。。。 思い出しながら調べながらだから結構かかりましたねぇ＾＾；；
貴重なお時間を頂戴しまして、誠に申し訳ございません。ありがとうございます。m(__)m
頂戴したコード、勉強させていただきます。
本当は、実際に試して、理解してからご返信させて頂こうかとも思ったのですが、
現在の私の理解度から見て、かなり時間がかかりそうでしたので、取り急ぎで大変恐縮ですが、
心より御礼申し上げます。
もこな２様
ご教示ありがとうございます。
なぜ、ブックを開きたくないのですか？
につきましては、今のコードですと、手動で全部ファイルを閉じなくてはならないので、バックグラウンド的に処理できる方法が別にあるはずと勝手に勘違いしていました。流石に自動で閉じることが出来ることは理解していますが、少々短絡的でした。
って感じにしたほうが、ステップ実行したときなど動きを確認しやすいように思えるんですがどうでしょう か
これにつきましては、ステップ実行の使い方を良くわかっていなかったこともありますが、ご指摘の通りです。何回かステップ実行は試していたのですが、流れが途中で追いきれなくなっておりました。
頂戴したコードにつきましても、頑張って理解しようと思います。ありがとうございます。m(__)m
お二人から頂いたご助言を無駄にしないためにも、頂いた内容をちゃんと理解する必要があると
感じましたので、御礼並びに結果のご報告まで、少々お時間頂戴できれば幸いでございます。
また、不慣れというのは言い訳にもなりませんが、スレッドの横線の区切りの入り方が良くわかって
おりませんので、もしご返信に齟齬がございましたら、ご容赦くださいませ。
何卒、宜しくお願い申し上げます。
（k-pon） 2018/06/02(土) 22:03
初めに書いておきます。
1）Findメソッドで無限ループになるかも知れません。
（途中でエラーで止まるので、とりあえず、終了は出来るはず。）
2）ハイパーリンクが上手くできるのと出来ないのとがあります。
（参照が不正です。みたいになったり、他にも何か違う表示が出たり＾＾；）
他ブックへハイパーリンクでセルの指定までしてジャンプするやり方がよくわかってないですが、
その辺の設定の話なのかなぁ。。。
ハイパーリンクをあきらめれば、別案は出来ると思いますが、、、、
データはバックアップを取ってお試しください。
ちょっと、自分では力不足ですが、書いたとこまで提示しておきます。
眠いのでこの辺でギブアップです＞＜
参考になれば。
Option Explicit
'***********************************************
'指定したフォルダー内（サブフォルダーも含む）エクセルファイルすべてを検索して、
'データを抽出し、索引を作るツール
'「File System Objyect」 を利用するので「Microsoft Scripting Runtime」を参照設定すること
'*******************************
Dim mobjFSO As FileSystemObject
Sub 複数ブック検索し索引を作成()
Dim wsResult As Worksheet
Dim sFolderPath As String
Dim sFileList() As String
Dim sKeyWord As String
' Application.ScreenUpdating = False
'キーワードの入力
If GetKeyWord(sKeyWord) = False Then Exit Sub
'検索するフォルダーのパスの選択
If GetFolderPath(sFolderPath) = False Then Exit Sub
'FSOの取得
Set mobjFSO = New FileSystemObject
'指定したフォルダ内（下位階層も含む）を検索したファイルのフルパスの一覧の取得
ReDim sFileList(1 To 5000)
If GetFileList(sFolderPath, sFileList) = False Then
MsgBox "注意。用意したメモリー領域を超えるファイル数がありました。", vbExclamation
Exit Sub
End If
'結果出力用シートの用意
Set wsResult = GetResultSheet()
'索引の作成
If CreateIndex(sFileList, sKeyWord, wsResult) = False Then
MsgBox "キーワードが見つかりませんでした。"
Exit Sub
End If
'索引にハイパーリンクの設定
SetLink wsResult
' Application.ScreenUpdating = True
End Sub
'**************************************************
'インプットボックスに入力したキーワードを返す自作関数
'引数：入力した文字列を受け取る変数（参照渡しします。）を指定してください。
'返り値：True/False（キャンセル時False)
'**************************************************
Private Function GetKeyWord(ByRef s As String) As Boolean
Dim ans As String
Do
ans = InputBox("検索文字列:", "指定するフォルダにある全Excelファイルを検索します")
If StrPtr(ans) = 0 Then Exit Function
Loop Until Len(ans) > 0
s = ans
GetKeyWord = True
End Function
'***********************************************************
'フォルダーを選択し、選択をしたフォルダーのパスを返す自作関数
'引数:フォルダーのパスを受け取る変数を指定（参照渡しします。）を指定してください。
'返り値：True/False（キャンセル時False)
'***********************************************************
Function GetFolderPath(ByRef s As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = "D:\user"
.AllowMultiSelect = False
.Title = "フォルダの選択"
If .Show Then
s = .SelectedItems(1)
GetFolderPath = True
End If
End With
End Function
'*************************************************************
'指定したフォルダー内の（サブフォルダーを含む）エクセルファイルのフルパスの一覧を返す自作関数
'第一引数：フォルダーのパスを示す文字列
'第二引数：リストを保持する変数（参照渡し）を指定してください。
'第三引数：データ数のカウンター
'第四引数：指定の親フォルダーかどうかのフラグ（２階層目以降はFalseを指定）
'返り値：ファイルのフルパスを示す文字列の一覧（1次配列）
'*************************************************************
Private Function GetFileList(ByVal sFolderPath As String, _
ByRef psFilesList() As String, _
Optional ByRef ix As Long = 0, _
Optional flg As Boolean = True) As Boolean
Dim oFile As File
Dim oFolder As Folder
Dim oSubFolder As Folder
Dim i As Long
If mobjFSO.FolderExists(sFolderPath) = False Then Exit Function
Set oFolder = mobjFSO.GetFolder(sFolderPath)
For Each oSubFolder In oFolder.SubFolders
If GetFileList(oSubFolder, psFilesList, ix, False) = False Then GoTo ErrH
Next
For Each oFile In oFolder.Files
If ix > UBound(psFilesList) Then GoTo ErrH
If mobjFSO.GetExtensionName(oFile.Path) = "xlsx" Then
ix = ix + 1
psFilesList(ix) = oFile.Path
End If
Next
If flg Then
If ix > 0 Then ReDim Preserve psFilesList(1 To ix)
End If
GetFileList = True
Exit Function
ErrH:
GetFileList = False
End Function
'*************************************************
'自ブックからコピーして新しいブックにした結果を書き込むシートを返す自作関数
'引数:なし
'返り値：新しいブックのシート
'**************************************************
Private Function GetResultSheet() As Worksheet
ThisWorkbook.Worksheets(1).Copy
Set GetResultSheet = Workbooks(Workbooks.Count).Worksheets(1)
GetResultSheet.UsedRange.Clear
End Function
'****************************************************
'索引を作成する自作関数
'******************************************************
Private Function CreateIndex(ByVal vFileList As Variant, _
ByVal sKeyWord As String, _
ByVal pwsResult As Worksheet) As Boolean
Dim vIndexList() As Variant
Dim v As Variant
Dim wb As Workbook
Dim ws As Worksheet
Dim ix As Long
ReDim vIndexList(1 To 5000, 1 To 2)
For Each v In vFileList
Set wb = Workbooks.Open(v, 0, True)
For Each ws In wb.Worksheets
GetCellAddress sKeyWord, ws.UsedRange, vIndexList, ix
Next
wb.Close
Next
If ix > 0 Then
pwsResult.Range("A1:D1").Value = Array("フルパス", "セルアドレス", "検索語", sKeyWord)
pwsResult.Range("A2").Resize(ix, 2).Value = vIndexList
CreateIndex = True
Else
pwsResult.Parent.Close False
End If
End Function
'****************************
'検索結果を一覧に作る
'***********************
Private Function GetCellAddress(ByVal psKeyWord As String, _
ByVal prngFind As Range, _
ByRef pvIndexList, _
ByRef pix As Long)
Dim rngFound As Range
Dim sFAddress As String
Set rngFound = prngFind.Find( _
What:=psKeyWord, _
After:=prngFind(prngFind.CountLarge), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=True, _
SearchFormat:=False)
If rngFound Is Nothing Then Exit Function
sFAddress = rngFound(1).Address
Do
pix = pix + 1
With prngFind.Worksheet.Parent
pvIndexList(pix, 1) = .Path & "\" & .Name
End With
pvIndexList(pix, 2) = rngFound.MergeArea.Address(False, False, , True)
Set rngFound = prngFind.FindNext(rngFound)
If rngFound Is Nothing Then Exit Do
Loop Until rngFound(1).Address = sFAddress
End Function
'**********************
'結果シートにハイパーリンク設定
'***********************
Private Sub SetLink(ByVal ws As Worksheet)
Dim rngData As Range
Dim c As Range
With ws.UsedRange
Set rngData = Intersect(.Cells, .Offset(1))
End With
For Each c In rngData.Columns(3).Cells
With c
.Worksheet.Hyperlinks.Add _
Anchor:=.Cells, _
Address:=c.Offset(, -2).Value, _
SubAddress:=c.Offset(, -1).Value, _
TextToDisplay:="Link"
End With
Next
End Sub
'************<プログラム終わり>**************
個人的な考えですが、
「ブックを開かずに」というテクニックは探せば出てきますが、
ほとんどが開いていることを見せてないだけで、メモリー上には開いているので、
開いても同じことだろうと思っています。
画面の更新を止めれば、開いていることを見せないように出来るので、
それで十分だろうし、今回の場合、開かない方が遅くなる可能性がありそうです。
（検証したわけではないですが＾＾；）
確かにこのようなプログラムは実行に時間が掛かりますが、
手動より速くて間違いがない（ロジックが間違ってたらだめですが＾＾；）ので、
それで十分だろうと思います。
速度的に我慢が出来ないなら、高性能のPCを買うことをお勧めします。
（まっつわん） 2018/06/02(土) 23:20
本当にありがとううございます。
ここまで詳しく教えていただけるとは、感謝の念にたえません。
結合セルがある場合、Findメソッドは使わない方が無難かも。。。
実はこの点は最初から気になっていましたが、私の場合はそれ以前の話でしたので、あまり考えていませんでした。ものすごく先になると思いますが、本件を十分に理解出来たら、チャレンジしてみたいです。
画面の更新を止めれば、開いていることを見せないように出来るので、 それで十分だろうし、今回の場合、開かない方が遅くなる可能性がありそうです。 （検証したわけではないですが＾＾；）
承知いたしました。ありがとうございます。
内容を理解してからですが、テスト環境を作って色々とテストしてみます。
ハイパーリンクをあきらめれば、別案は出来ると思いますが、、、、
ハイパーリンクにつきましては、色々な条件でやってみて、法則性が見つかりましたら
ご報告させていただきます。
眠いのでこの辺でギブアップです＞＜ 参考になれば。
本当にありがとうございます。m(__)m
お忙しい中ご指導いただきまして、本当にありがとうございました。m(__)m
前回のご助言についてまだ勉強中で、検証結果のご報告などが遅くなるかもしれませんが、
必ずご報告させていただきます。
もしまた分からないことがありましたら、ご相談させて頂けると幸いです。
（今度はもう少し基礎を理解してからご質問させて頂きます。）
何卒、宜しくお願い申し上げます。
（k-pon） 2018/06/03(日) 09:29
まっつわん さんへ
＞Findメソッドで無限ループに、はまった ＞＜ ＞結合セルがある場合、Findメソッドは使わない方が無難かも。。。
それはどういうことなんでしょうね？
結合セルとFindメソッドが絡むバグについては、 以前、βさんが解説していましたが、 ↓ 『ユーザーフォームでリストボックス検索から更新まで』（けんとくん） [[20170417102019]]
今回のコードは、それへの対応は済んでいるようなので、多分そのケースではないのでしょうね。
・・で、それ以外では、どんな状況で起きるのか体験してみたいので、 こちらでも再現できるサンプルデータをご提示いただくと有り難いのですが。 （無理にとは云いません。気が向いたらで結構です）
あと、これは、こちらのテストではトラブったです。 ↓ ＞GetResultSheet.UsedRange.Clear ↓の方が良くないですか？ GetResultSheet.UsedRange.Delete
実データ量より広目のUsedRangeを元シートから引き継ぐと 空データのアドレスをリンク設定に使おうとしてトラブっているように見えます。
（半平太） 2018/06/03(日) 14:05
無限ループにはまったデータは（ちなみに、エクセル2010で、テストしました）、、、
※試す方は実行前にEscキーを押す心の準備をしておいてください＾＾；
[B] [C] [D] [E] [F] [G] [H]
┌───────────┬───────────┐
[2] │ │ 退休寺 │
│ ここは退休寺です。 ├───────────┤
[3] │ │ 道路 │
└───────────┴───────────┘
[4]
こういった形に結合セルが配置されている場合です。
（間に列があっても、左上のセルが同じ行だとそうなる？
ちなみにオプションは、
検索場所：シート
検索方向：行
検索対象：値
□セルの内容が完全に同一・・・・
で、
検索する文字列：退休寺
全て検索としてみてください。
とりあえずの回避策は、検索方向を列にすると
一応回避できそうですが、例のパターンをあんまり試してないので、
怖いなというのが感想です。
＞あと、これは、こちらのテストではトラブったです。
なるほど、横着はだめですね＾＾；
結果出力用に、シートが1枚のブックを用意したいと思ったので、
どこからかコピーして新しいブックを作ってみましたが、
ロジックとしてちょっと横着かもですね＾＾；
既定の枚数でいいと諦めるか、オプションをいじった方がいいのかなぁ。。。。
いずれにしても、パイパーリンクの設定の仕方はもう一回勉強しないと、
なんか上手くいってないなーと思ってます＾＾；
あ、また横着なんですが、
GetResultSheet.UsedRange.Clear
GetResultSheet.UsedRange
と謎の呪文を繰り返すのも。。。ま、やめときますか＾＾；
（まっつわん） 2018/06/04(月) 09:30
＞前回のご助言についてまだ勉強中で、
＞検証結果のご報告などが遅くなるかもしれませんが、
＞必ずご報告させていただきます。
ゆっくりご自分で得心するまで勉強してください。
その中で生じる疑問等は別途どんどん質問してください。
そして、
理解した結果(内容)を、自分の言葉で説明できるようになれることを、期待してます。
（まっつわん） 2018/06/04(月) 10:09
お忙しい中、ありがとうございました。頑張ります。m(__)m
（k-pon） 2018/06/04(月) 11:45
まっつわんさんへ
お手数をおかけしました。
同条件でテストしましたが、現象は再現しませんでした。
ついでに細かい話ですが、
＞□セルの内容が完全に同一・・・・
これは、完全に同一にしてテストしろと言うことですね？
ご提示のコードは → LookAt:=xlPart, _ となっていて部分一致を示していますが・・
当方のテストでは、両方のケースで試しておりますけれども・・
（半平太） 2018/06/04(月) 14:27
これは、完全に同一にしてテストしろと言うことですね？ あ、チェックなしでという意味で。
＞同条件でテストしましたが、現象は再現しませんでした。
そうなんですねー。。。
こちらの環境だけの事象なんでしょうか。。。
それならそれでいいのですが。
こちらでは
B2
E2
E2
E2
・
・
・
とひたすら繰り返してくれます＞＜
なので最初にヒットしたアドレスを記録しておいても、
無限ループになってしまいます。
それはそれとして冷静になって対処すれば対処できないこともないですか。。。
（まっつわん） 2018/06/05(火) 08:02
まっつわん様から最後に頂いたコードについて、色々勉強しながら、少しずつ頂いたコードを
読み進めまして、完全な理解とは程遠いですが、どこで何をやろうとしているのかは理解できた
・・・ような気がします。
基礎を覚えてからと大見得を切ってしまった中お恥ずかしい限りですが、詰まってしまいました。
大変恐縮ですが、いくつか教えて頂きたいことがございます。基本的なことばかりで申し訳ございません。
（１）関数の呼び出しについて
Sub 複数ブック検索し索引を作成() の中の If GetKeyWord(sKeyWord) = False Then Exit Sub についてですが、Call文を省略して関数GetKeyWordを呼び出した上で、返り値がFalseだった場合 に処理を抜けるという認識で宜しいでしょうか。（以降の「GetFolderPath」「CreateIndex」なども同様？）
（２）Privateの使い分けについて
Private指定
GetFileList、GetResultSheet、CreateIndex、GetCellAddress、SetLink
Public
GetKeyWord、GetFolderPath
ですが、教科書的な意味での「Private」「Public」の使い分けは学習しましたが、理解が浅い気がします。
例えば、今回のケースでは、どこに注目すれば、「Private」「Public」の使い分けが理解できるのか
ご教示いただけると幸いです。
（３）参照渡しと値渡しについて
こちらも（２）と同じような話になってしまうと思いますが、参照渡しと値渡しの使い分けがまだ
理解しきれていません。
参照渡ししているもの（by Ref）
s、psFilesList()、ix、pvIndexList、pix
値渡ししているもの（by Val）
sFolderPath、vFileList、sKeyWord、pwsResult、psKeyWord、prngFind、Worksheet
値を固定したい場合に値渡し、変数的に扱いたいときに参照渡しを使うようなイメージで
認識しているのですが、上記区分との関係が理解できていません。アドバイス頂けると幸いです。
（４）GetFileList関数のflgについて
'第四引数：指定の親フォルダーかどうかのフラグ（２階層目以降はFalseを指定）
If flg Then If ix > 0 Then ReDim Preserve psFilesList(1 To ix) End If
の処理が理解できていません。
単純に意味だけ調べると、flgがTrueで、かつixが0より大きいときに、psFileListの添え字の最小値を
「1」にずらすと読み取ったのですが、親フォルダなどの話しと頭の中で繋げることができませんでした。
（５）.Parent.Closeについて
CreateIndex関数の中にある
pwsResult.Parent.Close False
ですが、これも意味だけ調べると、「pwsResultの親オブジェクトを確認メッセージなしで閉じる」になると思うのですが、これはブック（ファイル）を閉じる処理という認識で正しいでしょうか。
（６）GetCellAddress関数について
GetCellAddressの中に、
sFAddress = rngFound(1).Address
Do
pix = pix + 1
With prngFind.Worksheet.Parent
pvIndexList(pix, 1) = .Path & "\" & .Name
End With
pvIndexList(pix, 2) = rngFound.MergeArea.Address(False, False, , True)
Set rngFound = prngFind.FindNext(rngFound)
If rngFound Is Nothing Then Exit Do
Loop Until rngFound(1).Address = sFAddress
とありますが、特にsFAddress周辺の意味が理解できておりません。
最初に検索ワードが見つかった範囲を覚えておき、次の検索を繰り返し、何かが１周するまで処理を繰り返すという大ざっぱかつ適当な理解でおりますが、多分間違っていると思います。ご助言をお願いいたします。
（６）命名ルールについて
psFilelist()や、vFilelistなど、頭に「p」「s」「v」がついているようですが、
一般的でなくても構いませんので、命名ルールなどございましたら、教えて頂けると幸いです。
（７）シートのコピーについて
シートにマクロ起動用のボタンを配置しましたが、（当然の帰結ですが）GetResultSheetにより、結果シートに不要なボタンまでコピーされてしまいました。何か回避する策はございますでしょうか。
長々となってしまい申し訳ございません。
何卒、宜しくお願い申し上げます。
（k-pon） 2018/06/20(水) 18:11
>（１）関数の呼び出しについて >Call文を省略して関数GetKeyWordを呼び出した上で、返り値がFalseだった場合 >に処理を抜けるという認識で宜しいでしょうか。（以降の「GetFolderPath」「CreateIndex」なども同様？） そういうことです。 GetKeyWordの場合、 「OKを押したか、キャンセルを押したたか？」 という情報と、 「インプットボックスに入力された文字列」 という2種類の情報を返したいのですが、関数は1つしか答えを返せないので、 返り値としてはOK or Cancel の情報を返して、 入力された文字はByRefで渡した変数に受け取ります。
他の自作関数も、
返り値は、存在する/しないを返し、
その値は、渡された変数に書き込むよう作ってます。
>（２）Privateの使い分けについて >例えば、今回のケースでは、どこに注目すれば、「Private」「Public」の使い分けが理解できるのか >ご教示いただけると幸いです。 あ。今回のケースでは、どっちでも関係ないです。 使い分けは、他のモジュールからも見せたいか見せたくないかです。 ＜Module2＞に以下のように書いて、
Option Explicit
Private Sub test1()
End Sub
Public Sub test2()
End Sub
＜Module1＞
に、
Sub aaa()
Module2.
End Sub
と書いたときにメンバーとして出したくない時に（もちろん強引に書いても実行できません）、
Privateと書きます。
アプリがどんどん複雑になってきたときに、
迂闊に使ってはいけないサブルーチンや、
迂闊に使ってはいけない変数は、
その適用範囲を限定することで、
デバッグが少しでも楽にできであろうという考えです。
最初から全くバグがないプログラムを書けるなら、
このようなことは考えなくてもいいのですが、
そういうことはなかなかないので、
不要な時に、迂闊に触れないようにしてこうという考え方です。
詳しくは↓
http://darumaexcel.uijin.com/aboutooa/encapsulation_attr_method.html
あと、リボン等からマクロ一覧に表示したくない時もPrivateにしたら見えなくなると思います。
今回の場合は気分はメインのプロシージャ以外はPrivateにしておきたいですが、
書き忘れてる部分があるかも知れません。
>（３）参照渡しと値渡しについて
>こちらも（２）と同じような話になってしまうと思いますが、参照渡しと値渡しの使い分けがまだ
>理解しきれていません。 >値を固定したい場合に値渡し、変数的に扱いたいときに参照渡しを使うようなイメージで >認識しているのですが、上記区分との関係が理解できていません。アドバイス頂けると幸いです。
値渡しは、
下請に（サブルーチンに）、資料をコピーして渡して、これ見て集計した結果だけ返して
っていうようなときに使います。
つまり、渡した後、下請けがその値をどう加工 しようと知らないよというときに使います。
参照渡しは、
下請けに、原本の資料に必要事項を記入して返して、っていうときに使います。
結果として、仕事が終わった後、元の資料が、
値渡しの時は元のままで、
参照渡しの時は、何かが変更されてます。
つまり(1）の話の場合は、白紙を渡して何か結果を記入してもらうことを期待しているわけです。
逆にそれ以外の場合は、ByValを明示してます。
これも今回の場合そんなに問題にならないかも知れませんし、
ネット上のサンプルコードもほとんどByValを明示的に使っているものを見掛けませんが
(掲示板のサンプルはそうでもないと思いますが)、
ドンドン複雑なアプリを開発するようになった時に、
ByRefを迂闊に使うと、意図しないうちに値が変わっていて、
意図しない結果が返ってきてデバッグで苦労することがあるかも知れないので、
基本はByValで書きたいです。
この辺のByRef ByValは意図的に書くようにして癖をつけてます。
この辺もサンプルでは雑に運用しているかも知れませんが、
気持ちは、はっきり明示してはっきり区別したいなと思ってます。
>（４）GetFileList関数のflgについて
>psFileListの添え字の最小値を >「1」にずらすと読み取ったのですが、親フォルダなどの話しと頭の中で繋げることができませんでした。 読み間違いです。 最小値を変えているのではなく最大値を変えています。
＞ '指定したフォルダ内（下位階層も含む）を検索したファイルのフルパスの一覧の取得
＞ ReDim sFileList(1 To 5000)
ここで、配列の要素数(?)を大き目の5000に設定しているので（5000で大きいつもりだけど、人によっては少ないかも？）、
実際値が入っているところまでに再定義しているわけです。
flgは、最後に1回、その再定義をしたいために、使ってます。
その都度ReDimをして増やすという考えも出来ますが、回数が多くなるとその分処理が重くなります。
1回で済むなら1回で済ませたいという意図です。
>（５）.Parent.Closeについて >CreateIndex関数の中にある > pwsResult.Parent.Close False >ですが、これも意味だけ調べると、「pwsResultの親オブジェクトを確認メッセージなしで閉じる」に >なると思うのですが、これはブック（ファイル）を閉じる処理という認識で正しいでしょうか。 そうです。 ブックも変数に入れておいてもいいですが、 やたら滅多に変数を増やしたくないなと。 シートは、どのブックに属しているかの情報を持っているので、その情報を利用して操作すればいいかなと。
>（６）GetCellAddress関数について >GetCellAddressの中に、 > sFAddress = rngFound(1).Address > Do > pix = pix + 1 > With prngFind.Worksheet.Parent > pvIndexList(pix, 1) = .Path & "\" & .Name > End With > pvIndexList(pix, 2) = rngFound.MergeArea.Address(False, False, , True) > Set rngFound = prngFind.FindNext(rngFound) > If rngFound Is Nothing Then Exit Do > Loop Until rngFound(1).Address = sFAddress >とありますが、特にsFAddress周辺の意味が理解できておりません。 >最初に検索ワードが見つかった範囲を覚えておき、次の検索を繰り返し、何かが１周するまで処理を繰り返すという大ざっぱかつ適当な理解でおりますが、多分間違っていると思います。ご助言をお願いいたします。 話しはここからになります。 >Set rngFound = prngFind.Find( _ Findメソッドは手動の検索機能のことです。 で、FindNextメソッドは「次へ」のボタンを押す操作と同意です。 なので、最初に見つかったセルのアドレスを記録しておいて、 次に同じセルになったら、もうないと判断出来るわけです。 つまり、「全て検索」のボタンを押した結果をを再現するわけです。 検索機能は手動操作で設定したオプションがそのまま残ってしまうので、 マクロで実行するときに、引数を書くのを省略すると、思わぬ結果を返すので、 出来れば、マクロの記録でちゃんとした設定を記録してそれを使うのが良いと思います。 また、検索機能は結合セルがあると思わぬ挙動を示す場合があるようなので、 Findメソッドの使用には注意が必要です。（日付も上手く探せない場合がある。）
>（６）命名ルールについて >psFilelist()や、vFilelistなど、頭に「p」「s」「v」がついているようですが、 >一般的でなくても構いませんので、命名ルールなどございましたら、教えて頂けると幸いです。 この辺は個人ルールです。 sはString型の変数 vはVariant型の変数 pはPrivateの意味で、サブルーチン側で値を受け取る変数だよと明示したい場合。 （メインのプロシージャと同じ変数名でもいいけど、敢えて違う変数だよと明示したい。） あとは何かのインデックス番号のときは、ix Rangeオブジェクトはrng等 まぁ、個人で書くときはどうでもいいんですが、 まぁ、気分です。 チームで開発するときは当然、ルールを統一しなければなりません。 「接頭辞 命名規則」で検索すると、いくつか解説があるかも知れませんが、 時代とともに少しづつ考え方も変わってきているようです。
>（７）シートのコピーについて
>シートにマクロ起動用のボタンを配置しましたが、（当然の帰結ですが）GetResultSheetにより、
>結果シートに不要なボタンまでコピーされてしまいました。何か回避する策はございますでしょうか。
シートが1枚のブックを簡単に作りたいと思ったので、
シートを新規ブックにコピーしているわけですが、
1）コピーの対象をボタンの無いシートにするか、
2）コピーしたシートからボタンを削除するか、
3）コピーで無く、新規ブックを開くか
くらいでしょうか？
つたない説明で、いい加減な性格がコードにも説明にも出ちゃってますが、
伝わりますでしょうか？
参考になれば。
（まっつわん） 2018/06/21(木) 10:41
ありがとうございます！
おかげさまで、かなり理解が進みました。m(__)m
最初にやりたかったこともあと少しでできそうな気がします。
本当に助かりました。m(__)m
（k-pon） 2018/06/21(木) 10:57
追加箇所ですが、コード内にコメントで記載させて頂きましたが、
ざっくり下記２点です。
（１）xlsxだけでなくxlsファイルも対象にしました
（２）該当セルの左右も引っ張ってくるようにしました
元の行には、「変更前」、変更を加えた行には「変更後」と入れてあります。
（１）（２）ともに書き方としてもっとマシな書き方（特にGetCellAddressの部分）
はあると思うのですが、私の知識ではこれで精一杯なようです。
（２）につきましては、本当は行ごともってくる仕組みにしたかったのですが、コードが思いつかなかった
のと、フォーマットがバラバラなので重くなるのかとも思い、妥協しました。
createIndex関数の中で、使わない方が良いとご助言頂いた「On Error Resume Next」を使ってしまって
おりますが、パスワード付きのファイルに当たるとどうしても処理が中断してしまいましたので、
場所を限定して使わせて頂きました。
読み取り専用で開いているのに、何故か「ファイルを保存しますか？」と
時々聞かれましたので、createIndex関数に「wb.Saved = True」を差し込んでみたのですが、やはりファイルによっては聞いてくるようです。
もし、回避策をご存知でしたら、何度もお手数をおかけしますが、ご教示頂けると幸いでございます。
何卒、宜しくお願い申し上げます。
Option Explicit
'***********************************************
'指定したフォルダー内（サブフォルダーも含む）エクセルファイルすべてを検索して、
'データを抽出し、索引を作るツール
'「File System Objyect」 を利用するので「Microsoft Scripting Runtime」を参照設定すること
'*******************************
Dim mobjFSO As FileSystemObject
Sub 複数ブック検索し索引を作成()
Dim wsResult As Worksheet
Dim sFolderPath As String
Dim sFileList() As String
Dim sKeyWord As String
Application.ScreenUpdating = False
'キーワードの入力
If GetKeyWord(sKeyWord) = False Then Exit Sub
'検索するフォルダーのパスの選択
If GetFolderPath(sFolderPath) = False Then Exit Sub
'FSOの取得
Set mobjFSO = New FileSystemObject
'指定したフォルダ内（下位階層も含む）を検索したファイルのフルパスの一覧の取得
ReDim sFileList(1 To 5000)
If GetFileList(sFolderPath, sFileList) = False Then
MsgBox "注意。用意したメモリー領域を超えるファイル数がありました。", vbExclamation
Exit Sub
End If
'結果出力用シートの用意
Set wsResult = GetResultSheet()
'索引の作成
If CreateIndex(sFileList, sKeyWord, wsResult) = False Then
MsgBox "キーワードが見つかりませんでした。"
Exit Sub
End If
'索引にハイパーリンクの設定
SetLink wsResult
Application.ScreenUpdating = True
End Sub
'**************************************************
'インプットボックスに入力したキーワードを返す自作関数
'引数：入力した文字列を受け取る変数（参照渡しします。）を指定してください。
'返り値：True/False（キャンセル時False)
'**************************************************
Private Function GetKeyWord(ByRef s As String) As Boolean
Dim ans As String
Do
ans = InputBox("検索文字列:", "指定するフォルダにある全Excelファイルを検索します")
If StrPtr(ans) = 0 Then Exit Function
Loop Until Len(ans) > 0
s = ans
GetKeyWord = True
End Function
'***********************************************************
'フォルダーを選択し、選択をしたフォルダーのパスを返す自作関数
'引数:フォルダーのパスを受け取る変数を指定（参照渡しします。）を指定してください。
'返り値：True/False（キャンセル時False)
'***********************************************************
Function GetFolderPath(ByRef s As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = "D:\user"
.AllowMultiSelect = False
.Title = "フォルダの選択"
If .Show Then
s = .SelectedItems(1)
GetFolderPath = True
End If
End With
End Function
'*************************************************************
'指定したフォルダー内の（サブフォルダーを含む）エクセルファイルのフルパスの一覧を返す自作関数
'第一引数：フォルダーのパスを示す文字列
'第二引数：リストを保持する変数（参照渡し）を指定してください。
'第三引数：データ数のカウンター
'第四引数：指定の親フォルダーかどうかのフラグ（２階層目以降はFalseを指定）
'返り値：ファイルのフルパスを示す文字列の一覧（1次配列）
'*************************************************************
Private Function GetFileList(ByVal sFolderPath As String, _
ByRef psFilesList() As String, _
Optional ByRef ix As Long = 0, _
Optional flg As Boolean = True) As Boolean
Dim oFile As File
Dim oFolder As Folder
Dim oSubFolder As Folder
Dim i As Long
If mobjFSO.FolderExists(sFolderPath) = False Then Exit Function
Set oFolder = mobjFSO.GetFolder(sFolderPath)
For Each oSubFolder In oFolder.SubFolders
If GetFileList(oSubFolder, psFilesList, ix, False) = False Then GoTo ErrH
Next
For Each oFile In oFolder.Files
If ix > UBound(psFilesList) Then GoTo ErrH
' If mobjFSO.GetExtensionName(oFile.Path) = "xlsx" Then '変更前
If (mobjFSO.GetExtensionName(oFile.Path) = "xls") Or
(mobjFSO.GetExtensionName(oFile.Path) = "xlsx") Then '変更（対象にxlsを追加）
ix = ix + 1
psFilesList(ix) = oFile.Path
End If
Next
If flg Then
If ix > 0 Then ReDim Preserve psFilesList(1 To ix)
End If
GetFileList = True
Exit Function
ErrH:
GetFileList = False
End Function
'*************************************************
'自ブックからコピーして新しいブックにした結果を書き込むシートを返す自作関数
'引数:なし
'返り値：新しいブックのシート
'**************************************************
Private Function GetResultSheet() As Worksheet
ThisWorkbook.Worksheets(1).Copy
Set GetResultSheet = Workbooks(Workbooks.Count).Worksheets(1)
GetResultSheet.UsedRange.Clear
End Function
'****************************************************
'索引を作成する自作関数
'******************************************************
Private Function CreateIndex(ByVal vFileList As Variant, _
ByVal sKeyWord As String, _
ByVal pwsResult As Worksheet) As Boolean
Dim vIndexList() As Variant
Dim v As Variant
Dim wb As Workbook
Dim ws As Worksheet
Dim ix As Long
' ReDim vIndexList(1 To 5000, 1 To 2) '変更前
ReDim vIndexList(1 To 5000, 1 To 12) '変更後
For Each v In vFileList
On Error Resume Next 'エラー無視（パスワード付きファイルに当たるとエラーで止まってしまう ため）
' Set wb = Workbooks.Open(v, 0, True) '変更前
Set wb = Workbooks.Open(Filename:=v, UpdateLinks:=0, ReadOnly:=True, Password:="") '変 更後
For Each ws In wb.Worksheets
GetCellAddress sKeyWord, ws.UsedRange, vIndexList, ix
Next
wb.Close
On Error GoTo 0 'エラー復活
Next
If ix > 0 Then
' pwsResult.Range("A1:D1").Value = Array("フルパス", "セルアドレス", "検索語", sKeyWord) '変更前
pwsResult.Range("A1:L1").Value = Array("フルパス", "セルアドレス", sKeyWord, "左2列目",
"左1列目", "該当セル", "右1列目", "右2列目", "右3列目", "右4列目", "右5列目", "右6列目", "右7列目") '変更後
' pwsResult.Range("A2").Resize(ix, 2).Value = vIndexList '変更前
pwsResult.Range("A2").Resize(ix, 12).Value = vIndexList '変更後
CreateIndex = True
Else
wb.Saved = True '追加（効果なし？）
pwsResult.Parent.Close False
End If
End Function
'****************************
'検索結果を一覧に作る
'***********************
Private Function GetCellAddress(ByVal psKeyWord As String, _
ByVal prngFind As Range, _
ByRef pvIndexList, _
ByRef pix As Long)
Dim rngFound As Range
Dim sFAddress As String
Set rngFound = prngFind.Find( _
What:=psKeyWord, _
After:=prngFind(prngFind.CountLarge), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=True, _
SearchFormat:=False)
If rngFound Is Nothing Then Exit Function
sFAddress = rngFound(1).Address
Do
pix = pix + 1
With prngFind.Worksheet.Parent
pvIndexList(pix, 1) = .Path & "\" & .Name
End With
pvIndexList(pix, 2) = rngFound.MergeArea.Address(False, False, , True)
pvIndexList(pix, 3) = rngFound.Offset(0, -3).Value '追加
pvIndexList(pix, 4) = rngFound.Offset(0, -2).Value '追加
pvIndexList(pix, 5) = rngFound.Offset(0, -1).Value '追加
pvIndexList(pix, 6) = rngFound.Value '追加
pvIndexList(pix, 7) = rngFound.Offset(0, 2).Value '追加
pvIndexList(pix, 8) = rngFound.Offset(0, 3).Value '追加
pvIndexList(pix, 9) = rngFound.Offset(0, 4).Value '追加
pvIndexList(pix, 10) = rngFound.Offset(0, 5).Value '追加
pvIndexList(pix, 11) = rngFound.Offset(0, 6).Value '追加
pvIndexList(pix, 12) = rngFound.Offset(0, 7).Value '追加
Set rngFound = prngFind.FindNext(rngFound)
If rngFound Is Nothing Then Exit Do
Loop Until rngFound(1).Address = sFAddress
End Function
'**********************
'結果シートにハイパーリンク設定
'***********************
Private Sub SetLink(ByVal ws As Worksheet)
Dim rngData As Range
Dim c As Range
With ws.UsedRange
Set rngData = Intersect(.Cells, .Offset(1))
End With
' For Each c In rngData.Columns(3).Cells '変更前
For Each c In rngData.Columns(13).Cells '変更後
With c
' offsetの位置調整
.Worksheet.Hyperlinks.Add _
Anchor:=.Cells, _
Address:=c.Offset(, -12).Value, _
SubAddress:=c.Offset(, -11).Value, _
TextToDisplay:="Link"
End With
Next
End Sub
'************<プログラム終わり>**************
（k-pon） 2018/06/22(金) 18:21
>読み取り専用で開いているのに、何故か「ファイルを保存しますか？」と >時々聞かれましたので、createIndex関数に「wb.Saved = True」を差し込んで >みた のですが、やはりファイルに>よっては聞いてくるようです。
につきまして、自己解決しました。
Application.DisplayAlerts = False/True
を差し込んでみましたが、今のところ大丈夫そうです。
基本的なことで大変失礼いたしました。
（k-pon） 2018/06/26(火) 15:21
＞createIndex関数の中で、使わない方が良いとご助言頂いた「On Error Resume Next」を
＞使ってしまって おりますが、パスワード付きのファイルに当たるとどうしても
＞処理が中断してしまいましたので、
＞場所を限定して使わせて頂きました。
パスワードが掛かっているかどうかは、開いて見ないとわからないので、
その対応でよいです。
＞読み取り専用で開いているのに、何故か「ファイルを保存しますか？」と
＞時々聞かれましたので
読み取り専用で開いても名前を付けて保存はできるかな？
なので聞いてくる可能性はあります。
＞今のところ大丈夫そうです。
んー？なんでだろー
＞Application.DisplayAlerts = False/True ちょっと対応が乱暴な気がしないでもないですが、問題ないでしょう。
＞ wb.Saved = True '追加（効果なし？） ＞ pwsResult.Parent.Close False
とりあえず、同じブックを対象にしているなら同じ表現にした方がいいと思います。
とじるときにFalseにしてるのになんで保存するかなんで聞いてくるんだろ？
とは思いますが、後のデバッグはご自分でお願いします。
（まっつわん） 2018/06/27(水) 11:47
>とりあえず、同じブックを対象にしているなら同じ表現にした方がいいと思います。 >とじるときにFalseにしてるのになんで保存するかなんで聞いてくるんだろ？
私も不思議に思っています。もしかするとこちらの環境の問題かもしれません。
何か判明したらご報告させて頂きたく考えておりますが、条件がよく分からないので難しいかもしれません・・・
>とは思いますが、後のデバッグはご自分でお願いします。
承知いたしました。
ここまでお付き合いただきありがとうございました。心より感謝申し上げます。m(__)m
完全にお世話になりっぱなしでしたが、お陰様をもちまして、最初の目的を達成できました。
（k-pon） 2018/06/27(水) 16:47
＞Application.DisplayAlerts = False/True
では「保存しますか？」のダイヤログの抑制はできませんでした。
私の勘違いでした。m(__)m
もし何か判明しましたらご報告させて頂きます。
ありがとうございました。
（k-pon） 2018/06/27(水) 17:01
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.