Sub 指定フォルダのbook集計()
Dim folderPath As String
Dim fileName As String
Dim wb As Workbook
Dim ws As Worksheet
Dim newWb As Workbook
Dim newWs As Worksheet
Dim lastRow As Long
Dim newRow As Long
Dim i As Long
Dim dataArray As Variant
Dim desktopPath As String
Dim saveFileName As String
Dim todayDate 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 <> ""
' ブックを開く
Set wb = Workbooks.Open(folderPath & fileName)
' シートをループ
For Each ws In wb.Sheets
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row ' C列の最終行
' C列のデータを配列に読み込む
dataArray = ws.Range("C1:C" & lastRow).Value
' 3行目のタイトルを新しいシートにコピー
ws.Range(ws.Cells(3, 1), ws.Cells(3, 26)).Copy newWs.Cells(1, 1)
' 配列をループして「ABC」をあいまい検索
For i = 1 To UBound(dataArray, 1)
' C列の値に「ABC」が含まれているかチェック
If InStr(dataArray(i, 1), "ABC") > 0 Then
' A列にブック名を設定
newWs.Cells(newRow, 1).Value = wb.Name
' 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
Next ws
' ブックを閉じる
wb.Close SaveChanges:=False
fileName = Dir
Loop
' 今日の日付を取得し、_yyyymmdd形式にフォーマット
todayDate = Format(Date, "yyyymmdd")
' 新しいブックをデスクトップに保存
saveFileName = "ExtractedData_" & todayDate & ".xlsx"
newWb.SaveAs desktopPath & saveFileName
newWb.Close
MsgBox "データの抽出が完了しました！"
End Sub
指定フォルダのbook集計
