Excel2003：開かれていない複数ブックより、検索キーを含むシートをコピーしてくる方法

質問

Excelのマクロについてです。全く手がつけられないのでお知恵を拝借願えませんでしょうか。
あるシートに記載された検索キーをもとに複数ブックを検索し、そのデータを含むシートを拾い出すという作業を考えています。
あるレコード（数は10～50程度）に格納された文字列を複数ブックにわたって完全一致検索し、その文字列が含まれるシートを逐一拾ってくる（コピーしてくる）というマクロを考えています。

＜状態＞
レコードが入ったシート"C:\サンプル住所.xls"の内容：
シートは一枚（シート名：検索元）
セルD5　東京都港区
セルD6　青森県青森市
セルD7　東京都港区
セルD8　北海道足寄町
セルD9　福岡県北九州市
レコードはすべて文字列です。この例では5つですが、レコード数は1～多くても50くらいの間で変動し、同じ文字列が複数回出現することもあります。セル結合はありません。

検索先であるデータベース（以下"ＤＢ"）は下位ディレクトリ（Prefフォルダ）に各都道府県のブックを放り込んであります：
C:\Prefs\北海道.xls
C:\Prefs\青森.xls
C:\Prefs\宮城.xls
（以下続く）
これら各ブックはシート1枚のみの構成で、セル結合はありません。またデータの重複はありません。なおブックの総数は47都道府県分とは限らず、検索内容によって変動します。

＜目標＞
"ＤＢ"内に"東京都港区"が存在するかどうかを検索し、見つかったら"C:\サンプル住所.xls"の最後に該当シートを追加。見つからなかった場合は空白シートを追加。どちらの場合もシート名は連番＆検索キーとします。
これをレコードの数だけループさせ、検索されたシートがぎっしり詰まったブックを完成させます。
つまり、完成後のシートは左から以下のように並びます。
検索元 ＞ 1_東京都港区 ＞ 2_青森県青森市 ＞ 3_東京都港区 ＞ 4_北海道足寄町 ＞ 2_大阪府大阪市

検索の導入部分としてダイアログを出しＤＢのディレクトリを選ぶところや、シート名をつけなおすあたりはさすがに何とかなるのですが・・・
ワークシート関数でしたらそれなりに使えるのですが、ブックをまたいだ作業はどこから手をつければいいのか皆目わからず。
ポインタやヒント、サンプル等、ご教示頂けると大変助かります。

自分でどこまで組み立てたのか？の思考の過程すら提示できずお恥ずかしい限りですが、なにとぞよろしくお願いします。

回答No.3

kenpon24 · ベストアンサー

あらかじめファイルリストを作成するサンプルです。
#2さんの書き込みを見て気づいたんですが、1レコード検索する毎に
全エクセルファイルをオープン、クローズしているので
実行速度が遅いかもしれません。

Option Base 0
Option Explicit

Sub test()
　　Dim i As Long
　　Dim j As Long
　　Dim SearchWord As String
　　Dim FileList() As String
　　Dim FileCnt As Long
　　Dim ws As Worksheet

　　Set ws = ActiveSheet

　　Application.ScreenUpdating = False
　　'ディレクトリ指定でエクセルファイルのリストを作成する
　　FileCnt = GetAllxlsFilesInDir("D:", FileList())

　　For i = 1 To Range("D65536").End(xlUp).Row
　　　　ws.Activate
　　　　SearchWord = Range("D" & i)

　　　　If SearchWord = "" Then
　　　　　　GoTo NEXT_RECORD
　　　　End If

　　　　'毎回Openを繰り返しているので遅いかも・・・
　　　　For j = 0 To FileCnt - 1

　　　　　　Workbooks.Open(FileList(j)).Activate

　　　　　　'レコードの検索
　　　　　　If (Cells.Find(What:=SearchWord, after:=ActiveCell, LookIn:=xlFormulas, _
　　　　　　　　　　LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
　　　　　　　　　　MatchCase:=True, SearchFormat:=False) Is Nothing = False) Then

　　　　　　　　'見つかったらシートのコピー&リネーム
　　　　　　　　With ThisWorkbook
　　　　　　　　　　ActiveSheet.Copy after:=.Sheets(.Sheets.Count)
　　　　　　　　　　.Sheets(.Sheets.Count).Name = i & "_" & SearchWord
　　　　　　　　End With

　　　　　　　　'閉じて次のレコードを探す
　　　　　　　　Workbooks(Dir(FileList(j))).Close savechanges:=False
　　　　　　　　GoTo NEXT_RECORD
　　　　　　End If

　　　　　　Workbooks(Dir(FileList(j))).Close savechanges:=False

　　　　Next j

　　　　'見つからなかったら空白のシートを追加
　　　　With ThisWorkbook
　　　　　　.Activate
　　　　　　Sheets.Add
　　　　　　ActiveSheet.Move after:=.Sheets(.Sheets.Count)
　　　　　　.Sheets(.Sheets.Count).Name = i & "_" & SearchWord
　　　　End With

NEXT_RECORD:

　　Next i

　　ws.Activate

　　Application.ScreenUpdating = True

　　Erase FileList
　　Set ws = Nothing

End Sub

'フォルダ内のエクセルファイルのファイルリスト作成
'引数1:検索フォルダパス 引数2:ファイルリスト
'戻り値:見つかったファイル数
Function GetAllxlsFilesInDir(ByVal strDirPath As String, ByRef xlsFiles() As String) As Long

　　Dim strTempName As String
　　Dim FileCnt　　As Long

　　On Error GoTo GetAllFiles_End

　　FileCnt = 0
　　' strDirPath が "\" 文字で終わっていることを確認します。
　　If Right$(strDirPath, 1) <> "\" Then
　　　　strDirPath = strDirPath & "\"
　　End If

　　' strDirPath がディレクトリであることを確認します。
　　If GetAttr(strDirPath) And vbDirectory <> vbDirectory Then
　　　　GoTo GetAllFiles_End
　　End If

　　'エクセルファイルを検索する
　　strTempName = Dir(strDirPath & "*.xls")

　　Do Until Len(strTempName) = 0

　　　　' "." と ".." を除外
　　　　If (strTempName = ".") Or (strTempName = "..") Then
　　　　　　GoTo NEXT_DIR
　　　　End If

　　　　If strTempName Like "*.xls" Then
　　　　　　'サブフォルダリストに登録する
　　　　　　FileCnt = FileCnt + 1
　　　　　　ReDim Preserve xlsFiles(FileCnt)
　　　　　　xlsFiles(FileCnt - 1) = strDirPath & strTempName
　　　　End If

NEXT_DIR:
　　　　' Dir 関数を使用して、次のファイル名を検索します。
　　　　strTempName = Dir()
　　Loop

GetAllFiles_End:

　　GetAllxlsFilesInDir = FileCnt

End Function

お礼

ありがとうございます。
原理はこれから勉強するところですが、ピンポイントで問題が解決できましたのでたいへん助かりました。
最初に回答を頂いた方の手順も美しいですが、こちらはいかにも動かしているといった感じでわかりやすいです。実行速度も特に気になりません。
大変勉強になりました。ありがとうございます。

回答No.4

imogasi

>複数ブックを検索し、
（１）
そのブックは１つのフォルダの下に有るのか。それなら
Ｇｏｏｇｌｅで「フォルダ　ファイル　ＶＢＡ」でＷＥＢ照会のこと。（先ほどもこの質問があった。）ＷＥＢに記事がいっぱいある。
ＤＩＲ利用
ＦＳＯ利用（ＦＳＯの意味は、Ｇｏｏｇｌｅで照会のこと）
の２方式の解説がある。
（２）シート
１つのブック名を捉えたとき、全シート名を捉えるのは
Sub test01()
Set wb = Workbooks.Open("01化.xls")
For Each sh In wb.Worksheets
MsgBox sh.Name
Next
End Sub
のように簡単なコードで捉えられる。
（３）
しかしエクセルの操作で、検索・置換はブック全体（全シート、検索場所=ブック）を対象にできるようになっているから、それを使えば、全シートを個々に捕まえる必要ない。
（４）マクロの記録をとって、勉強すること
　（３）の操作をしてマクロの記録をとり、検索のコードがどのようになり、本質問のためには、どこを変えるべきか勉強のこと。マクロの記録を利用する事が質問に出ていないのはおかしい。
（５）問題はブックを開かずに処理が出来るかどうか。
Ｖｉｓｉｂｌｅ＝Ｆａｌｓｅで画面に出さない程度で処理が速くできるのか
（先日も質問のあったが）エクセル４．０マクロで開かずに読んで処理できるのか、実際やってみないとわからない。
普通には質問者は、ＶＢＡの熟練者で無いようだから、ブックをＯｐｅｎしー＞処理しーー＞Ｃｌｏｓｅするの繰り返しで我慢してもらいたい。
エクセルはデータを別ブックに分けると処理がしづらい。この報いは必ず後でやってくる。表計算が多シートになったのもここ１５年ぐらいだ。ファイルが別だと別世界。それを関連付けて扱うＶＢＡの技量は上級者の者と思う。当面は無理しすぎの課題と思う。

お礼

は。すみません。背伸びどころではない内容です。
しかしこうして手順や原理から教えて頂けるのは大変有り難く思います。
すぐに答えが出なくても、この積み重ねでいずれは皆さんに回答者としてフィードバックできるよう、精進して参ります。
マクロの記録でいろいろいじってみたのですが、本文に書くと無駄に長くなってしまったのでばっさり切ってしまいました。手抜きのようで申し訳ありません。
ありがとうございました。

回答No.2

n-jun

＃１です。

レコード毎にファイルを開く・閉じるも大変そうなので、一旦新規Bookを作成し、
そこに集めたシートを検索対象としてます。

Sub try()
Dim wb_main As Workbook
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws As Worksheet
Dim r As Range, rm As Range
Dim ch As Boolean
Dim Fname As String

Application.ScreenUpdating = False

Set wb_main = ThisWorkbook

' 一旦各ファイルのシート（１）を新規Bookに集める
Set wb1 = Workbooks.Add

Fname = Dir("C:\Prefs\*.xls")

Do Until Fname = ""

Set wb2 = Workbooks.Open("C:\Prefs\" & Fname)

wb2.Worksheets(1).Copy After:=wb1.Worksheets(wb1.Worksheets.Count)
ActiveSheet.Name = Replace(Fname, ".xls", "")

wb2.Close False

Fname = Dir()
Loop
' --------------------------------------------------

With wb_main.Worksheets("検索元")
Set rm = .Range(.Range("D5"), .Cells(Rows.Count, 4).End(xlUp))
End With

For Each r In rm

ch = False

For Each ws In wb1.Worksheets
If Application.CountIf(ws.Cells, r.Value) > 0 Then
ws.Copy After:=wb_main.Worksheets(wb_main.Worksheets.Count)
ActiveSheet.Name = wb_main.Worksheets.Count & "_" & ws.Name
ch = True
End If
Next

If ch = False Then Worksheets.Add After:=wb_main.Worksheets(wb_main.Worksheets.Count)

Next

Application.DisplayAlerts = False
wb1.Close
Application.DisplayAlerts = True

Set wb_main = Nothing
Set wb1 = Nothing
Set wb2 = Nothing
Application.ScreenUpdating = True
End Sub

意図が違ったらごめんなさい。

お礼

ありがとうございます。先にシートを拾ってしまうとさすがに動作が速いですね。
今回はこの方法は採用しませんでしたが、他に使いたい場所があるので活用させてください。
大変参考になりました。ありがとうございます。

回答No.1

n-jun

この例題の場合、
＞セルD8　北海道足寄町
の検索対象ブックは
＞C:\Prefs\北海道.xls
のみとなりそうですが違うのでしょうか？

「北海道足寄町」等のデータで『都道府県名』を基にすれば、複数ブックを
検索していく必要はないように思いますけど。

もし”例”としてあげているだけならば、スル～して下さい。

補足

ご指摘いただきありがとうございます。
検索キーや対象ブック名はあくまで例でして、キーの先頭数文字で対象となるブックを類推できるものではありません。
シート名はバラバラで、やはり前提どおり全てのブックを検索する必要があります。
あぁ、ボロの出ない例を考えていたのに・・・
何卒宜しくお願いします。