Option Explicit
Sub ProcessExcelFiles()
Dim objExcel As Variant
Dim objWorkbook9 As Variant
Dim objWorkbook As Variant
Dim objSheet As Variant
Dim objFSO As Variant
Dim objFolder As Variant
Dim objFile As Variant
Dim lastRow As Integer
Dim sourceRange As Variant
Dim targetSheet As Variant
Dim targetRow As Integer
' Excelを起動
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True ' Excelを表示
' Excelファイル9を作成
Set objWorkbook9 = objExcel.Workbooks.Add
Set targetSheet = objWorkbook9.Sheets(1)
targetRow = 1 ' 初期行設定
' フォルダZ内のファイルを処理
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Path\To\FolderZ")
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 5)) = ".xlsx" Or LCase(Right(objFile.Name, 4)) = ".xls" Then
' Excelファイルを開く
Set objWorkbook = objExcel.Workbooks.Open(objFile.Path)
Set objSheet = objWorkbook.Sheets("A")
' "総計"が含まれる行を特定
lastRow = FindTotalRow(objSheet)
If lastRow > 2 Then
' データをコピー
Set sourceRange = objSheet.Range(objSheet.Cells(3, 1), objSheet.Cells(lastRow, 20))
sourceRange.Copy
targetSheet.Cells(targetRow, 1).PasteSpecial -4163 ' xlPasteValues の代用
targetRow = targetRow + sourceRange.Rows.Count
End If
' ファイルを閉じる
objWorkbook.Close False
End If
Next objFile
' Excelを保存(必要に応じて変更)
objWorkbook9.SaveAs "C:\Path\To\FolderZ\Excel9.xlsx"
objWorkbook9.Close
objExcel.Quit
' 後片付け
Set objWorkbook9 = Nothing
Set objWorkbook = Nothing
Set objSheet = Nothing
Set objFSO = Nothing
Set objFolder = Nothing
Set objExcel = Nothing
MsgBox "処理が完了しました。"
End Sub
Function FindTotalRow(objSheet As Variant) As Integer
Dim i As Integer
Dim lastRow As Integer
lastRow = objSheet.Cells(objSheet.Rows.Count, 1).End(-4162).Row ' xlUp の代用
For i = 1 To lastRow
If objSheet.Cells(i, 1).Value = "総計" Then
FindTotalRow = i
Exit Function
End If
Next i
FindTotalRow = 0
End Function