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

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

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

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

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

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

このQ&Aに関連する最新のQ&A

A 回答 (4件)

あらかじめファイルリストを作成するサンプルです。


#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
    • good
    • 0
この回答へのお礼

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

お礼日時:2009/05/27 01:01

>複数ブックを検索し、


(1)
そのブックは1つのフォルダの下に有るのか。それなら
Googleで「フォルダ ファイル VBA」でWEB照会のこと。(先ほどもこの質問があった。)WEBに記事がいっぱいある。
DIR利用
FSO利用(FSOの意味は、Googleで照会のこと)
の2方式の解説がある。
(2)シート
1つのブック名を捉えたとき、全シート名を捉えるのは
Sub test01()
Set wb = Workbooks.Open("01化.xls")
For Each sh In wb.Worksheets
MsgBox sh.Name
Next
End Sub
のように簡単なコードで捉えられる。
(3)
しかしエクセルの操作で、検索・置換はブック全体(全シート、検索場所=ブック)を対象にできるようになっているから、それを使えば、全シートを個々に捕まえる必要ない。
(4)マクロの記録をとって、勉強すること
 (3)の操作をしてマクロの記録をとり、検索のコードがどのようになり、本質問のためには、どこを変えるべきか勉強のこと。マクロの記録を利用する事が質問に出ていないのはおかしい。
(5)問題はブックを開かずに処理が出来るかどうか。
Visible=Falseで画面に出さない程度で処理が速くできるのか
(先日も質問のあったが)エクセル4.0マクロで開かずに読んで処理できるのか、実際やってみないとわからない。
普通には質問者は、VBAの熟練者で無いようだから、ブックをOpenしー>処理しーー>Closeするの繰り返しで我慢してもらいたい。
エクセルはデータを別ブックに分けると処理がしづらい。この報いは必ず後でやってくる。表計算が多シートになったのもここ15年ぐらいだ。ファイルが別だと別世界。それを関連付けて扱うVBAの技量は上級者の者と思う。当面は無理しすぎの課題と思う。
    • good
    • 0
この回答へのお礼

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

お礼日時:2009/05/27 00:58

#1です。



レコード毎にファイルを開く・閉じるも大変そうなので、一旦新規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

' 一旦各ファイルのシート(1)を新規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

意図が違ったらごめんなさい。
    • good
    • 0
この回答へのお礼

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

お礼日時:2009/05/27 01:03

この例題の場合、


>セルD8 北海道足寄町
の検索対象ブックは
>C:\Prefs\北海道.xls
のみとなりそうですが違うのでしょうか?

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

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

この回答への補足

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

補足日時:2009/05/25 09:51
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!


人気Q&Aランキング