'//指定フォルダの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
