VBA_09_Type_Class Module_Collection_SubFolders_SaveAs_Sample

keyword
---
Type
Class Module
SubFolders
Collection
SaveAs
Workbooks.Open

Sample code
---
```vb:複数ブックを開ぎ、指定したシートから合計を取得する
Option Explicit

Private Type MyType
    myFso As New FileSystemObject
    myFolder As Folder
    myCurrentFolder As Folder
    myFile As File

    myMainSheet As Worksheet
    myResultSheet As Worksheet
    myResultTemplateSheet As Worksheet
    myNewBook As Workbook
    myReportSheet As Worksheet
    mySheetsInNewWorkbook As Long
    myDefalutSaveFormat As Long
    mySingleBook As Workbook
    mySheet As Worksheet

    myInputPath As String
    myOutputPath As String
    myRow As Long

    myResultList As Collection
    myOutputInfo As OutputInfo
End Type

Public Sub Excute()
    
    Dim myType2 As MyType
    
    With myType2
        Set .myMainSheet = ActiveSheet
        .myInputPath = .myMainSheet.Range("C2").Value
        .myOutputPath = .myMainSheet.Range("C3").Value
        
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False

        Application.AutomationSecurity = msoAutomationSecurityForceDisable
    
        Set .myResultList = New Collection
        
        Call SearchBooks(myType2)
        
        DoEvents
        
        Set .myResultSheet = GetSheetForActivate(myType2)
        
        Call SpreadReportInfo(myType2)
        
        DoEvents
        
        .myResultSheet.SaveAs .myOutputPath & "\" & _
            Format(Now(), "yyyymmddhhmmss") & "_結果.xlsx", xlOpenXMLWorkbook
        
        Application.AutomationSecurity = msoAutomationSecurityLow
        
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        
        MsgBox "終了"
    
    End With

End Sub

Private Sub SearchBooks(ByRef pMyType As MyType)
    
    With pMyType
        On Error Resume Next
    
        Set .myCurrentFolder = .myFso.getFolder(.myInputPath)
        
        If Err.Number <> 0 Then
            MsgBox Err.Description, vbExclamation + vbOKOnly
            Exit Sub
        End If
        On Error GoTo 0
    
        For Each .myFolder In .myCurrentFolder.SubFolders
            SearchBooks pMyType
        Next
    
        For Each .myFile In .myCurrentFolder.Files
    
            Application.StatusBar = .myFile.Path & " を検索中..."
    
            If .myFile.Name Like "*.xls*" Then
    
                SearchSingleBook pMyType
            Else
    
                Set .myOutputInfo = New OutputInfo
    
                .myOutputInfo.myFileName = .myFile.Name
                .myOutputInfo.myMessage = "対象外ファイルです。"

                .myResultList.Add .myOutputInfo
            End If
    
            Application.StatusBar = False
    
        Next
        
        Set .myFso = Nothing
    
    End With

End Sub

Private Sub SearchSingleBook(ByRef pMyType As MyType)

    With pMyType
        On Error Resume Next
        Set .mySingleBook = Application.Workbooks.Open( _
            Filename:=.myFile.Path, UpdateLinks:=0, ReadOnly:=True)
    
        If Err.Number <> 0 Then
            Set .myOutputInfo = New OutputInfo
            .myOutputInfo.myFileName = .myFile.Name
            .myOutputInfo.myMessage = "ファイルを開けません。"
            .myResultList.Add .myOutputInfo
            Exit Sub
        End If
        On Error GoTo 0
    
        For Each .mySheet In .mySingleBook.Sheets
        
            If .mySheet.Name = .myMainSheet.Range("C5").Value Then
                Set .myOutputInfo = New OutputInfo
                .myOutputInfo.myFileName = .myFile.Name
                .myOutputInfo.mySheetName = .mySheet.Name
                .myOutputInfo.myTotalSum = .mySheet.Cells(.mySheet.UsedRange.Rows(.mySheet.UsedRange.Rows.Count).Row, _
                                                            .mySheet.UsedRange.Columns(.mySheet.UsedRange.Columns.Count).Column).Value
                .myResultList.Add .myOutputInfo
            End If
        Next

        If Not .mySingleBook Is Nothing Then
            .mySingleBook.Close False
        End If
    
    End With

End Sub

Private Function GetSheetForActivate(ByRef pMyType As MyType) As Worksheet

    With Application
        pMyType.mySheetsInNewWorkbook = .SheetsInNewWorkbook
        pMyType.myDefalutSaveFormat = .DefaultSaveFormat
        .SheetsInNewWorkbook = 1
        .DefaultSaveFormat = xlOpenXMLWorkbook
        Set pMyType.myNewBook = .Workbooks.Add
        .SheetsInNewWorkbook = pMyType.mySheetsInNewWorkbook
        .DefaultSaveFormat = pMyType.myDefalutSaveFormat
    End With
    
    With pMyType
        Set .myResultTemplateSheet = ThisWorkbook.Sheets("レポート結果")
        .myResultTemplateSheet.Copy after:=.myNewBook.Worksheets(Worksheets.Count)
        .myNewBook.Sheets("Sheet1").Delete
        Set GetSheetForActivate = ActiveSheet
    End With
    
End Function

Private Sub SpreadReportInfo(ByRef pMyType As MyType)

    pMyType.myRow = 3

    With pMyType

        For Each .myOutputInfo In .myResultList

            .myRow = .myRow + 1

            .myResultSheet.Cells(.myRow, 1) = .myRow - 3
            .myResultSheet.Cells(.myRow, 2) = .myOutputInfo.myFileName
            .myResultSheet.Cells(.myRow, 3) = .myOutputInfo.mySheetName
            .myResultSheet.Cells(.myRow, 4) = .myOutputInfo.myTotalSum
            .myResultSheet.Cells(.myRow, 5) = .myOutputInfo.myMessage

        Next

    End With

End Sub

Public Sub SelectInputBaseDir()
    Dim rng As Range

    Set rng = ActiveSheet.Range("C2")

    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = rng.Value & "\"
        If .Show Then
            rng.Value = .SelectedItems(1)
        End If
    End With

End Sub

Public Sub SelectOutputBaseDir()
    Dim rng As Range

    Set rng = ActiveSheet.Range("C3")

    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = rng.Value & "\"
        If .Show Then
            rng.Value = .SelectedItems(1)
        End If
    End With
End Sub
```
```vb:Class Module : OutputInfo
Option Explicit

Public myFileName As String
Public mySheetName As String
Public myTotalSum As Long
Public myMessage As String

```