0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

111

Posted at

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

0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?