エクセルのブック内の検索一覧

質問

エクセル2003VBAについて教えてください。

複数のブックがあり、ブックの中にはいくつかの同じ内容のシートがあります。
シートの内容は、
A1セルには、○か×が入ります。
A2セルには、このブック名とシート名が入っています。
A3セルにはいろいろな文字列が入っています。

A1が○のブック内のシートを探して、別のブックへ

｜A2セルの内容｜A3セルの内容｜

というリストを作成したいのですが、どのように組めばよいでしょうか。

回答No.1

end-u · ベストアンサー

>どのように組めばよいでしょうか。
QNo.4143734 のコードを組める方なら、それほど難しくないと思うのですが...？

最近似たような他の質問（QNo.4134321）に掲載したコードがありましたのでちょっと修正してみました。
新規Bookの標準モジュールに後述のコードを置いて実行します。
その複数のBookは１つのフォルダにまとめてあるものとします。

'以下標準モジュールに置く。
Option Explicit

Sub try()
　　Dim brw As Object
　　Dim ws　As Worksheet
　　Dim fd　As String
　　Dim fn　As String
　　Dim re　As String
　　Dim i　 As Long
　　Dim n　 As Long
　　Dim v(0 To 65535, 1 To 4)

　　Set brw = CreateObject("Shell.Application") _
　　　　　　　.BrowseForFolder(0, "SelectFolder", 0)
　　If brw Is Nothing Then Exit Sub
　　fd = brw.self.Path & "\"
　　Set brw = Nothing
　　If MsgBox(fd & " の処理を行います。OK?", vbOKCancel) _
　　　　　　 = vbCancel Then Exit Sub
　　With Application
　　　　.ScreenUpdating = False
　　　　.EnableEvents = False
　　　　.Calculation = xlCalculationManual
　　End With
　　v(0, 1) = "BookName"
　　v(0, 2) = "SheetName"
　　v(0, 3) = "A2"
　　v(0, 4) = "A3"
　　On Error GoTo errHndlr
　　fn = Dir(fd & "*.xls")
　　Do Until Len(fn) = 0&
　　　　If Not fn Like ThisWorkbook.Name Then
　　　　　　With Workbooks.Open(Filename:=fd & fn, _
　　　　　　　　　　　　　　　　Updatelinks:=False, _
　　　　　　　　　　　　　　　　ReadOnly:=True)
　　　　　　　　i = i + 1
　　　　　　　　For Each ws In .Worksheets
　　　　　　　　　　If ws.Range("A1").Value = "○" Then
　　　　　　　　　　　　n = n + 1
　　　　　　　　　　　　v(n, 1) = fd & fn
　　　　　　　　　　　　v(n, 2) = ws.Name
　　　　　　　　　　　　v(n, 3) = ws.Range("A2").Value
　　　　　　　　　　　　v(n, 4) = ws.Range("A3").Value
　　　　　　　　　　End If
　　　　　　　　Next ws
　　　　　　　　.Close Savechanges:=False
　　　　　　End With
　　　　End If
　　　　fn = Dir()
　　Loop

errHndlr:
　　If i > 0& Then
　　　　Sheets.Add.Range("A1").Resize(n + 1, UBound(v, 2)).Formula = v
　　End If
　　With Application
　　　　.Calculation = xlCalculationAutomatic
　　　　.EnableEvents = True
　　　　.ScreenUpdating = True
　　End With
　　If Err.Number = 0& Then
　　　　re = i & " Books & " & n & " Sheets" & vbLf & "処理終了"
　　Else
　　　　re = Err.Number & vbLf & Err.Description
　　End If
　　MsgBox re
　　Set ws = Nothing
End Sub

お礼

すごいです！！！
希望通りのものができました。
内容については、まだ理解できておりませんが、
お答えを参考にじっくり勉強したいとおもいます。

どうもありがとうございました！