先生: 今日は「指定フォルダ内のExcelファイルを集計してデータを取り出す」コードを紹介するで！このコード、フォルダ内にあるExcelファイルを見て、条件に合うデータを集めて新しいファイルにまとめるんや。
生徒: へぇ〜、それはすごいですね！どうやって集めるんですか？
先生: まずは、フォルダのパスを指定して、そのフォルダ内にあるExcelファイルをひとつひとつ開くんや。それで、「C列」に「ABC」っていう文字が入ってるデータを探すんやで。
生徒: なるほど！じゃあ、条件に合うデータをどうやって見つけるんですか？
先生: いい質問や！もしExcelファイルのデータが500件以上あったら、ADODBっていう特別な方法を使って、データベースみたいに検索するんや。それを使うと、いっぱいデータがあっても早く探せるんやで。
生徒: 500件以上だと、普通に探すのは遅いから特別な方法が必要なんですね！
先生: その通り！で、もし500件未満なら、普通にExcelのセルを順番に見ていく方法を使うんや。でも、どちらにしても「C列」の中に「ABC」って入ってるかどうかをチェックしてるんや。
生徒: なるほど！「ABC」っていう文字があるかチェックするんですね！それを新しいファイルにまとめるんですか？
先生: そうや！条件に合うデータを新しいシートにコピーして、最終的にデスクトップに新しいファイルとして保存するんやで。名前は今日の日付をつけて「ExtractedData_yyyymmdd.xlsx」ってなるんや。
生徒: それって、毎回同じ名前で保存しなくていいから便利ですね！でも、「ADODB」ってよくわからないんですが、どういうものですか？
先生: 「ADODB」は、Excelの外にあるデータをExcelで扱うための道具やと思ってくれたらいいよ。例えば、Excelのファイルをデータベースみたいに扱うことができるんや。これを使うと、大量のデータを効率よく検索できるんやで。
生徒: なるほど、普通の方法だと遅いけど「ADODB」を使うと早くできるんですね！
先生: そうやね！この方法を使うと、もっとたくさんのデータを素早く処理できるんやで。こういうちょっとした工夫で、仕事がスムーズになるんやな。
生徒: わかりました！いろんなデータを集めるときに使える技ですね！
'//指定フォルダのbook集計 その2(500件以上はADODB利用)
Sub 指定フォルダのbook集計2()
Dim folderPath As String
Dim fileName As String
Dim newWb As Workbook
Dim newWs As Worksheet
Dim newRow As Long
Dim todayDate As String
Dim conn As Object
Dim rs As Object
Dim sql As String
Dim fullPath As String
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
' デスクトップのパスを取得
Dim desktopPath As String
desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
' 指定フォルダーのパスを入力
folderPath = "C:\Your\Folder\Path\" ' フォルダーのパスを適宜変更してください
' 新しいブックの作成
Set newWb = Workbooks.Add
Set newWs = newWb.Sheets(1)
newRow = 2 ' 1行目にタイトルを書き込むので、新しいデータは2行目から始める
' 指定フォルダー内のファイルをループ
fileName = Dir(folderPath & "*.xls*") ' Excelファイルを検索
Do While fileName <> ""
fullPath = folderPath & fileName
' まずはExcelを開いて行数を確認
Set wb = Workbooks.Open(fullPath)
Set ws = wb.Sheets(1) ' シート名を適宜変更
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row ' C列の最終行
' 3行目のタイトルを新しいシートにコピー
ws.Range(ws.Cells(3, 1), ws.Cells(3, 26)).Copy newWs.Cells(1, 2) ' B1からZ1にタイトルをコピー
newWs.Cells(1, 1).Value = "ブック名" ' A1に「ブック名」を追加
If lastRow > 500 Then
' ADODBを使用してExcelファイルを接続
Set conn = CreateObject("ADODB.Connection")
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & fullPath & ";Extended Properties='Excel 12.0 Xml;HDR=YES';"
' C列に「ABC」が含まれる行を検索するSQL
sql = "SELECT * FROM [Sheet1$] WHERE C LIKE '%ABC%'" ' シート名を適宜変更
' SQLを実行
Set rs = conn.Execute(sql)
' 結果を新しいシートに書き込む
Do While Not rs.EOF
newWs.Cells(newRow, 1).Value = fileName ' A列にブック名を追加
' 各列をB列からZ列に書き込む
For i = 1 To 26
newWs.Cells(newRow, i + 1).Value = rs.Fields(i - 1).Value
Next i
newRow = newRow + 1
rs.MoveNext
Loop
' 接続を閉じる
rs.Close
conn.Close
Else
' 通常の方法で処理する場合
' 結果を新しいシートに書き込む
Dim dataArray As Variant
dataArray = ws.Range("C1:C" & lastRow).Value
' 配列をループして「ABC」をあいまい検索
For i = 1 To UBound(dataArray, 1)
' C列の値に「ABC」が含まれているかチェック
If InStr(dataArray(i, 1), "ABC") > 0 Then
' A列にブック名を設定
newWs.Cells(newRow, 1).Value = fileName
' A列からZ列を新しいシートにコピー（B列からZ列）
ws.Range(ws.Cells(i, 1), ws.Cells(i, 26)).Copy newWs.Cells(newRow, 2)
newRow = newRow + 1
End If
Next i
End If
' ブックを閉じる
wb.Close SaveChanges:=False
fileName = Dir
Loop
' 今日の日付を取得し、_yyyymmdd形式にフォーマット
todayDate = Format(Date, "yyyymmdd")
' 新しいブックをデスクトップに保存
newWb.SaveAs desktopPath & "ExtractedData_" & todayDate & ".xlsx"
newWb.Close
MsgBox "データの抽出が完了しました！"
End Sub
