フォルダ内にある複数のブックからシートを読み取り結合します。
参照設定
- Microsoft Office*.* Object Library
- Microsoft Scripting Runtime
コード
Option Explicit
Const TARGET_SHEET_NAME As String = "結合したいシート名"
Const RESULT_SHEET_NAME As String = "結果出力用の新規シート名"
Const NOT_NULL_COLUMN As Long = 1
Const IS_WINDOW_VISIBLE As Boolean = False
Public Sub CombineFile()
If existSheet(ThisWorkbook, RESULT_SHEET_NAME) Then
MsgBox "既に[" & RESULT_SHEET_NAME & "]シートが存在します"
Exit Sub
End If
Dim resultSheet As Worksheet
Set resultSheet = Worksheets.Add()
resultSheet.Name = RESULT_SHEET_NAME
Dim targetFolderPath As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.InitialFileName = ThisWorkbook.Path & "\"
If .Show = True Then
targetFolderPath = .SelectedItems(1) & "\"
Else
MsgBox "フォルダが選択されませんでした"
Exit Sub
End If
End With
Dim wb As Workbook
Dim ws As Worksheet
Dim startRow As Long
Dim lastRow As Long
Application.ScreenUpdating = False
startRow = 2
Dim fso As FileSystemObject
Dim f As File
Set fso = New FileSystemObject
For Each f In fso.GetFolder(targetFolderPath).Files
If LCase(fso.GetExtensionName(f.Name)) Like "xls*" Then
Set wb = Workbooks.Open(Filename:=f.Path)
Windows(wb.Name).Visible = IS_WINDOW_VISIBLE
If existSheet(wb, TARGET_SHEET_NAME) Then
Set ws = wb.Worksheets(TARGET_SHEET_NAME)
With ws
If .AutoFilterMode Then
If .AutoFilter.FilterMode Then
.AutoFilterMode = False
End If
End If
lastRow = GetLastRow(NOT_NULL_COLUMN, ws)
If startRow = 2 Then
.Range(.Rows(1), .Rows(lastRow)).Cells.Copy
With resultSheet
.Range(.Rows(startRow - 1), .Rows(startRow + lastRow - 2)).PasteSpecial
End With
Else
.Range(.Rows(2), .Rows(lastRow)).Cells.Copy
With resultSheet
.Range(.Rows(startRow), .Rows(startRow + lastRow - 2)).PasteSpecial
End With
End If
End With
startRow = startRow + lastRow - 1
Application.DisplayAlerts = False
wb.Close
Application.DisplayAlerts = True
Set ws = Nothing
Set wb = Nothing
End If
End If
Next f
Set fso = Nothing
resultSheet.Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub
Private Function existSheet(wb As Workbook, sheetName As String) As Boolean
Dim ws As Worksheet
Dim ef As Boolean
ef = False
For Each ws In wb.Worksheets
If ws.Name = sheetName Then
ef = True
Exit For
End If
Next
existSheet = ef
End Function
Public Function GetLastRow(Optional ColumnNum As Long = 1, Optional ThisSheet As Worksheet) As Long
If ThisSheet Is Nothing Then
Set ThisSheet = ActiveSheet
End If
With ThisSheet
GetLastRow = .Cells(.Rows.CountLarge, ColumnNum).End(xlUp).Row
End With
End Function
定数
- TARGET_SHEET_NAME:各ブックにある結合したいシート名
- RESULT_SHEET_NAME:結果出力用の新規シート名
- NOT_NULL_COLUMN : 必ず値が入っている列番号(最終行を判定するために使用)
- IS_WINDOW_VISIBLE :ループ処理の際、対象ワークブックの表示設定(Trueで表示)