VBAでExcelファイルを処理するテンプレート集｜開く・保存・閉じる

Option Explicit

Private Const DEST_SHEET_NAME As String = "集計"
Private Const LOG_SHEET_NAME As String = "処理ログ"

' フォルダパスの末尾に \ を付けて返します。
Public Function AddTrailingBackslash(ByVal folderPath As String) As String
    If Len(folderPath) = 0 Then
        AddTrailingBackslash = ""
    ElseIf Right$(folderPath, 1) = "\" Then
        AddTrailingBackslash = folderPath
    Else
        AddTrailingBackslash = folderPath & "\"
    End If
End Function

' フォルダ選択画面を表示し、選択されたフォルダパスを返します。キャンセル時は "" を返します。
Public Function PickFolder( _
    Optional ByVal dialogTitle As String = "処理するフォルダを選択してください", _
    Optional ByVal initialFolder As String = "") As String

    Dim fd As FileDialog
    Dim selectedFolder As String

    If Len(initialFolder) = 0 Then
        initialFolder = ThisWorkbook.Path
    End If

    Set fd = Application.FileDialog(msoFileDialogFolderPicker)

    With fd
        .Title = dialogTitle

        If Len(initialFolder) > 0 Then
            .InitialFileName = AddTrailingBackslash(initialFolder)
        End If

        If .Show <> -1 Then
            PickFolder = ""
            Exit Function
        End If

        selectedFolder = .SelectedItems(1)
    End With

    PickFolder = AddTrailingBackslash(selectedFolder)
End Function

' Dir関数で対象ファイルのフルパス一覧を Collection として返します。
Public Function GetExcelFiles( _
    ByVal folderPath As String, _
    Optional ByVal filePattern As String = "*.xlsx") As Collection

    Dim files As Collection
    Dim fileName As String

    Set files = New Collection
    folderPath = AddTrailingBackslash(folderPath)

    fileName = Dir(folderPath & filePattern)

    Do While fileName <> ""
        If Left$(fileName, 2) <> "~$" Then
            files.Add folderPath & fileName
        End If
        fileName = Dir()
    Loop

    Set GetExcelFiles = files
End Function

' Excelブックを安全設定で開き、開いた Workbook を返します。
Public Function OpenExcelWorkbook( _
    ByVal filePath As String, _
    Optional ByVal readOnlyMode As Boolean = True, _
    Optional ByVal updateLinksMode As Long = 0, _
    Optional ByVal ignoreReadOnlyRecommendedMode As Boolean = True) As Workbook

    If Len(Dir(filePath)) = 0 Then
        Err.Raise vbObjectError + 1000, , "ファイルが見つかりません: " & filePath
    End If

    Set OpenExcelWorkbook = Workbooks.Open( _
        Filename:=filePath, _
        UpdateLinks:=updateLinksMode, _
        ReadOnly:=readOnlyMode, _
        IgnoreReadOnlyRecommended:=ignoreReadOnlyRecommendedMode, _
        AddToMru:=False)
End Function

' 保存先フォルダ、基本名、拡張子から、日時付きの保存先フルパスを返します。
Public Function BuildSavePath( _
    ByVal saveFolder As String, _
    ByVal baseName As String, _
    Optional ByVal extension As String = ".xlsx") As String

    saveFolder = AddTrailingBackslash(saveFolder)

    If Left$(extension, 1) <> "." Then
        extension = "." & extension
    End If

    BuildSavePath = saveFolder & baseName & "_" & Format(Now, "yyyymmdd_hhnnss") & extension
End Function

' 複数のExcelファイルを開き、明細シートを集計シートへ追記して結果を保存します。
Public Sub ImportExcelFilesToSummary( _
    ByVal sourceFolder As String, _
    ByVal saveFolder As String, _
    Optional ByVal filePattern As String = "*.xlsx", _
    Optional ByVal sourceSheetName As String = "明細")

    Dim files As Collection
    Dim filePath As Variant
    Dim srcWb As Workbook
    Dim srcWs As Worksheet
    Dim dstWs As Worksheet
    Dim logWs As Worksheet
    Dim srcRange As Range
    Dim copyRows As Long
    Dim nextRow As Long
    Dim logRow As Long
    Dim savePath As String

    On Error GoTo ErrorHandler

    Set dstWs = ThisWorkbook.Worksheets(DEST_SHEET_NAME)
    Set logWs = ThisWorkbook.Worksheets(LOG_SHEET_NAME)
    Set files = GetExcelFiles(sourceFolder, filePattern)

    If files.Count = 0 Then
        MsgBox "対象ファイルが見つかりませんでした。", vbInformation
        Exit Sub
    End If

    dstWs.Cells.Clear
    dstWs.Range("A1:F1").Value = Array("元ファイル", "日付", "拠点", "担当", "商品", "金額")
    nextRow = 2

    logWs.Cells.Clear
    logWs.Range("A1:D1").Value = Array("時刻", "ファイル", "結果", "メモ")
    logRow = 2

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For Each filePath In files
        Set srcWb = OpenExcelWorkbook(CStr(filePath), True, 0, True)
        Set srcWs = srcWb.Worksheets(sourceSheetName)
        Set srcRange = srcWs.Range("A1").CurrentRegion

        If srcRange.Rows.Count > 1 Then
            copyRows = srcRange.Rows.Count - 1

            dstWs.Cells(nextRow, 1).Resize(copyRows, 1).Value = srcWb.Name
            srcRange.Offset(1, 0).Resize(copyRows, 5).Copy Destination:=dstWs.Cells(nextRow, 2)

            nextRow = nextRow + copyRows
        End If

        logWs.Cells(logRow, 1).Value = Now
        logWs.Cells(logRow, 2).Value = srcWb.Name
        logWs.Cells(logRow, 3).Value = "OK"
        logWs.Cells(logRow, 4).Value = copyRows & "行を取り込み"
        logRow = logRow + 1

        srcWb.Close SaveChanges:=False
        Set srcWb = Nothing
    Next filePath

    dstWs.Columns.AutoFit
    logWs.Columns.AutoFit

    savePath = BuildSavePath(saveFolder, "集計結果", ".xlsx")

    ThisWorkbook.Worksheets(DEST_SHEET_NAME).Copy
    ActiveWorkbook.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close SaveChanges:=False

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    MsgBox files.Count & "件のファイル処理が完了しました。" & vbCrLf & savePath, vbInformation
    Exit Sub

ErrorHandler:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    If Not srcWb Is Nothing Then
        srcWb.Close SaveChanges:=False
    End If

    MsgBox "ファイル処理中にエラーが発生しました。" & vbCrLf & _
           "対象: " & CStr(filePath) & vbCrLf & _
           Err.Description, vbExclamation
End Sub

' マクロ一覧から実行する入口です。フォルダ選択から集計まで呼び出します。
Public Sub RunFileProcessingTemplate()
    Dim sourceFolder As String
    Dim saveFolder As String

    sourceFolder = PickFolder("取り込み元のExcelファイルが入ったフォルダを選択してください")
    If sourceFolder = "" Then Exit Sub

    saveFolder = PickFolder("集計結果を保存するフォルダを選択してください")
    If saveFolder = "" Then Exit Sub

    ImportExcelFilesToSummary sourceFolder, saveFolder, "*.xlsx", "明細"
End Sub