フォルダ内の特定ファイル特定シート特定セルの値を集計１

Option Explicit

Const strSearchWord As String = "削除" & vbLf & "フラグ"
Const strDefFileName As String = "RPA用集計.xlsx"
Const masterSheet As String = "マスタ"  'マクロツールブックのマスタシート名
Const masterStartRow As Integer = 7
Dim strFolderPath As String
Dim fileName As String
Dim shName As String
Dim strCellAddress As String
Dim strRowNum As String
Dim strColName As String
Dim intFileStartRow As Integer
Dim intFileLastRow As Integer
Dim val1 As String 'マクロツールブックより部署名格納
Dim val2 As String 'マクロツールブックよりグループ名格納
Dim targetPeriod As Date '対象期間の日付を格納（yyyy年4月1日またはyyyy年10月1日)
Dim lngResultNum As Long '各ファイルの集計結果の数値を格納
Dim blBookOpend As Boolean '対象ブックが既に開かれているかTrueかFalseで格納

Sub main()
    Debug.Print "■mainプロシージャ開始■"
'----------------------------------
    '変数宣言
    Dim lastRow As Integer
    Dim i As Integer
    Dim strDate As String
    Dim repotBook As Workbook
    Dim toolBook As Workbook
    ThisWorkbook.Activate
    Set toolBook = ActiveWorkbook
'-------------------------------------------------------------------------------
'RPA集計用.xlsxのファイル名のブックが開かれているか確認する
    blBookOpend = sameNameBookOpenCheck(strDefFileName)
    If blBookOpend Then
        MsgBox strDefFileName & "を閉じてから再実行してください。"
        Exit Sub
    End If
'--------------------------------------------------------------------------------
    'マスタシートのD列（対応フォルダの列）の最終行取得
    lastRow = toolBook.Sheets(masterSheet).Cells(Rows.Count, 4).End(xlUp).Row
    Debug.Print "最終行：" & lastRow
'--------------------------------------------------------------------------------
    Application.ScreenUpdating = False
    'D列の最終行まで繰り返し処理
    For i = 7 To lastRow
        '---------------------------------------------------
        '初期化(フォルダパスと検索用の文字列の値格納用変数）
        strFolderPath = ""
        val1 = ""
        val2 = ""
        '---------------------------------------------------
        '検索値,フォルダパス，対象期間を取得
        With toolBook.Sheets(masterSheet)
            val1 = .Cells(i, 2).Value
            val2 = .Cells(i, 3).Value
            strFolderPath = .Cells(i, 4).Value
            '-------------------------------------------------
            'マスタシート各セルより年月を取得して日付型に変換
            strDate = Cells(3, 5).Value
            strDate = strDate & Cells(3, 6).Value
            targetPeriod = CDate(strDate)
            '-------------------------------------------------
        End With
        '-----------------------------------------------
        'ログ出力
        Debug.Print "val1         : " & val1
        Debug.Print "val2         : " & val2
        Debug.Print "targetPeriod : " & targetPeriod
        Debug.Print "strFolderPath: " & strFolderPath
        Debug.Print "テストプロシージャを呼び出し"
        '-----------------------------------------------
        '該当シート名を取得
        Call Process1(strFolderPath)
        '------------------------------------------------
        'ログ出力
        Debug.Print "◎mainプロシージャに戻った◎"
        Debug.Print "strFolderPath : " & strFolderPath
        Debug.Print "shName        : " & shName
        Debug.Print "fileName      : " & fileName
        Debug.Print "strCellAddress: " & strCellAddress
        Debug.Print "intFileLastRow: " & intFileLastRow
        Debug.Print "strRowNum; " & strRowNum
        '-----------------------------------------------
        '結果をシートに書き出し
'        With ThisWorkbook.Sheets(masterSheet)
        With toolBook.Sheets(masterSheet)
            .Cells(i, 5) = fileName
            .Cells(i, 6) = shName
            .Cells(i, 7) = intFileStartRow
            .Cells(i, 8) = intFileLastRow
            .Cells(i, 9) = lngResultNum
            '対象ファイルが既に開かれていて処理不可だった場合は
            'エラーメッセージ書込み
            If blBookOpend Then
                .Cells(i, 10) = "ファイルが既に開かれている為処理できませんでした。"
            End If
        End With
        '------------------------------------------------
    Next
    Application.ScreenUpdating = False
      
End Sub

Sub Process1(targetPath)
'---------------------------------------------------------------------------
'機能 :指定されたフォルダ内の全てのファイルの全てのシートを一つ一つ調べ、
      '検索値に合致する値が入力されているセルの存在するシート名を取得する。
'引数1:確認対象のフォルダパス
'---------------------------------------------------------------------------
    '初期化
    intFileLastRow = 0
    '------------------------------------------------
    'ログ出力
    Debug.Print "-------------------------------"
    Debug.Print "■testプロシージャ開始■"
    Debug.Print "△開始時の値△"
    Debug.Print "strFolderPath : " & strFolderPath
    Debug.Print "intFileLastRow: " & intFileLastRow
    '-------------------------------------------------
    Dim wb As Workbook
    
    'フォルダ内の全てのファイルを確認
    fileName = Dir(targetPath & "\" & "*.xlsx")
    Do While fileName <> ""
        '------------------------------------------------------------
        'ログ出力
        Debug.Print "fileName: " & fileName
        'ブックが開かれているか確認する
        blBookOpend = IsBookOpened(targetPath & "\" & fileName)
        
        '対象ファイルが既に開かれていなかった場合の処理
        If blBookOpend = False Then
        '-----------------------------------------------------------
            'リンクを更新しないでブックを開く
            Set wb = Workbooks.Open(targetPath & "\" & fileName, False)
            '------------------------------------------------------------
            'ログ出力
             Debug.Print "searchCellプロシージャ呼び出し"
             Debug.Print targetPath & fileName
             '-----------------------------------------------------------
            '該当セルを検索
            Call searchCell(wb, strSearchWord)
            '----------------------------------------------------------
            'ログ出力
            Debug.Print "◎testプロシージャに戻った◎"
            '------------------------------------------------------------
            'シート名が空白以外の場合は計算処理と転記を行い、ループを抜ける
            If shName <> "" Then
                '--------------------------------------------------------
                '削除フラグ文言のあるセルアドレスの行数を取得
                 Call editCellAddress(strCellAddress)
                 'スタート行に4行プラスして正しいスタート行に修正
                 intFileStartRow = intFileStartRow + 4
                 '-------------------------------------------------------
                'ログ出力
                Debug.Print "◎テストプロシージャに戻った"
                '--------------------------------------------------------
                '対象シートにフィルタがかかっていた場合は解除
                Call ReleaseFilter(wb, shName)
                intFileLastRow = wb.Sheets(shName).Cells(Rows.Count, 4).End(xlUp).Row
                '--------------------------------------------------------
                'ログ出力
                Debug.Print "◎テストプロシージャに戻った"
                '--------------------------------------------------------
                '計算対象データか判定
                lngResultNum = fncCalc(wb, shName, intFileStartRow, intFileLastRow)
                '---------------------------------------------------------
                'クローズメソッドの引数（ファイルを保存しないをfalseに設定）
                '該当シートが見つかったらファイルを閉じてループを抜ける
                wb.Close (False)
                Set wb = Nothing
                Exit Do
            End If
            '-------------------------------------------------------------
            'シートが見つからなかったらファイルを閉じて
            '次回ループのためにDir関数を初期化
            fileName = Dir()
            wb.Close (False)
            Set wb = Nothing
        '------------------------------------------------------------------
        Else
            'ファイルが既に開かれていて処理できない場合はループを抜ける
            MsgBox "ブックは開かれています"
            Exit Sub
        End If
        '-------------------------------------------------------------------
    Loop
End Sub

Sub searchCell(wb As Workbook, strSearchWord As String)
'-------------------------------------------------------
'機能1：渡されたブックのシート全てを調べ、特定の値の入ったセルのアドレスを返す
'機能2：該当のせるのあったシートのシート名を返す
'引数1：確認するブックを格納したワークブックオブジェクト
'引数2：検索値の文字列
'--------------------------------------------------------
    'セルアドレスを初期化
    strCellAddress = ""
    'シート名を初期化
    shName = ""
'-------------------------------------------------------
    'ログ出力
    Debug.Print "■SearchCellプロシージャ開始■"
    Debug.Print "△開始時の値△"
    Debug.Print "fileName      :" & fileName
    Debug.Print "shName        :" & shName
    Debug.Print "strCellAddress:" & strCellAddress
    Debug.Print "strSearchWord :" & strSearchWord
'------------------------------------------------------
    Dim shCount As Integer
    Dim sh As Variant
    Dim foundCell As Range
 '-----------------------------------------------------
    'ファイル内のシート数を取得
    shCount = wb.Sheets.Count
    '全シート分、該当セルが見つかるまで繰り返し処理
    For Each sh In wb.Sheets
        '該当セルを検索（セル結合ありも対応）
        Set foundCell = wb.Sheets(sh.Name).Cells.Find(what:=strSearchWord, Searchorder:=xlByRows)
        '該当セルが存在したらセルアドレスとシート名を取得し、ループを抜ける
        If Not foundCell Is Nothing Then
            shName = sh.Name
            strCellAddress = foundCell.Address
            Exit For
        End If
    Next
'-------------------------------------------------------
    'ログ出力
    Debug.Print "△終了時の値△"
    Debug.Print "shName        :" & shName
    Debug.Print "strCellAddress:" & strCellAddress
    Debug.Print "■SearchCellプロシージャ終了■"
'-------------------------------------------------------
End Sub
Sub editCellAddress(strCellAddress)
'-------------------------------------------------------
'機能：セルアドレスより行数・列名を取得する
'引数1:セルアドレス
'結果1：変数strRowNumに行数を格納
'結果2：変数strColNameに列名を格納
'-------------------------------------------------------
    Dim reg As Object
    Set reg = CreateObject("VBScript.RegExp")
    strRowNum = ""
    intFileStartRow = 0
    strColName = ""
'--------------------------------------------------------
    '行数取得
    With reg
        .Pattern = "[A-Z,$]"
        .IgnoreCase = False
        .Global = True
    End With
    strRowNum = reg.Replace(strCellAddress, "")
    Debug.Print "strRowNum     : " & strRowNum
    intFileStartRow = CInt(strRowNum)
    Debug.Print "intFileStartrow: " & intFileStartRow
    
'---------------------------------------------------------
    '列名取得
    With reg
        .Pattern = "[0-9,$]"
        .IgnoreCase = False
        .Global = True
    End With
    strColName = reg.Replace(strCellAddress, "")
    
End Sub

Sub ReleaseFilter(wb As Workbook, shName As String)
'--------------------------------------------------
'機能：指定したブックの指定したシートにフィルタが
'      かかっているか確認し、フィルタを解除する
'引数1:対象ワークブックオブジェクト
'引数2:対象シート名
'--------------------------------------------------
    Dim filterRange As String
'--------------------------------------------------
'ログ出力
    Debug.Print "■ReleaseFilter開始■"
    Debug.Print "△開始時の値△"
    Debug.Print "shName: " & shName
'--------------------------------------------------
    'フィルタがかかっていたらフィルタのかかっている範囲を取得
    With wb.Sheets(shName)
        If .AutoFilterMode Then
           filterRange = .AutoFilter.Range.Address
           Debug.Print filterRange
           'フィルタを解除
            Range(filterRange).AutoFilter
        End If
    End With
'--------------------------------------------------
    Debug.Print "■ReleaseFilter終了■"
    
End Sub

Function fncCalc(wb As Workbook, shName As String, intFileStartRow As Integer, intFileLastRow As Integer) As Long
'------------------------------------------
'機能：対象ファイルの開始行から最終行までの
'      対象データの合計を10倍した数値を返す。
'引数1:対象のワークブックオブジェクト
'引数2:対象のシート名
'引数3:開始行
'引数4:終了行
'------------------------------------------
    Dim i As Integer
    Dim strDeleteFlag As String
    Dim targetDate As Date
    Dim lngTargetNum As Long
    Dim lngTotalNum As Long '合計の数値
    Dim TargetFlag As Boolean
    '--------------------------------------
    '初期化
    strDeleteFlag = ""
'    targetDate = Nothing
    lngTargetNum = 0
    lngTotalNum = 0
    '--------------------------------------
    'ログ出力
    Debug.Print "■fncCalc開始■"
    Debug.Print "△開始時の値△"
    Debug.Print "shName         : " & shName
    Debug.Print "intFileStartRow: " & intFileStartRow
    Debug.Print "intFileLastRow : " & intFileLastRow
    Debug.Print "strDeleteFlag  : " & strDeleteFlag
    Debug.Print "targetDate     : " & targetDate
    Debug.Print "lngTargetNum   : " & lngTargetNum
    '--------------------------------------
    For i = intFileStartRow To intFileLastRow
        With wb.Sheets(shName)
            '---------------------------------
            '削除フラグ,開始日,金額の値を取得
            strDeleteFlag = .Cells(i, 3).Value
            targetDate = .Cells(i, 5).Value
            lngTargetNum = .Cells(i, 4).Value
            '---------------------------------
            '集計対象データかチェック
            TargetFlag = fncCheckData(strDeleteFlag, targetDate)
            '---------------------------------
            'ログ出力
            Debug.Print "◎fncCalcに戻り◎"
            Debug.Print "targetFlag: " & TargetFlag
            '---------------------------------
            '対象データなら足し算
            If TargetFlag Then
                lngTotalNum = lngTotalNum + lngTargetNum
            End If
            '--------------------------------
            'ログ出力
            Debug.Print "i: " & i
            Debug.Print "lngTargetNum : " & lngTargetNum
            Debug.Print "lngTotalNum  : " & lngTotalNum
            '---------------------------------
        End With
    Next
    
    '合計値を10倍する
    fncCalc = lngTotalNum * 10
    '----------------------------------------
    'ログ出力
    Debug.Print "fncCalc      : " & fncCalc
    '----------------------------------------
End Function

Function fncCheckData(strDeleteFlag As String, targetDate As Date) As Boolean
'-------------------------------------------------
'機能：削除フラグの欄が空欄で開始日が対象期間以降
'　　　の場合はTrue,それ以外の場合はFalseを返す。
'引数1：削除フラグの欄の文字列
'引数2：開始日の日付
'-------------------------------------------------
    '初期化
    fncCheckData = True
    '----------------------------
    'ログ出力
    Debug.Print "■fncCheckData開始■"
    Debug.Print "△開始時の値△"
    Debug.Print "targetPeriod   : " & targetPeriod
    Debug.Print "strDeleteFlag  : " & strDeleteFlag
    Debug.Print "targetDate     : " & targetDate
    '----------------------------
    If strDeleteFlag = "削除" Then
        fncCheckData = False
    End If
    If targetDate < targetPeriod Then
        fncCheckData = False
    End If
    '----------------------------
    'ログ出力
    Debug.Print "■fncCheckData終了■"
    Debug.Print "△終了時の値△"
    Debug.Print "fncCheckData   : " & fncCheckData
    '----------------------------
End Function

Function StartCheck(strRange1 As String, strRange2 As String) As Boolean
    Dim strErr As String
    With ThisWorkbook.Sheets("マスタ")
        If .Range(strRange1) = "" Then
            strErr = "対象年" & vbCrLf
        End If
        If .Range(strRange2) = "" Then
            strErr = "対象月日"
        End If
    End With
    If strErr <> "" Then
        strErr = vbCrLf & "以下の項目をしてから実行1ボタンを押して下さい。"
        StartCheck
    End If
End Function

Public Function IsBookOpened(ByVal FilePath As String) As Boolean
'-----------------------------------------------------------------
'機能：対象ブックが既に開かれているか確認しTrueかFalseを返す
'引数1：対象ブックのパス
'----------------------------------------------------------------
  On Error Resume Next
     Open FilePath For Append As #1
     Close #1
     Debug.Print Err.Number
     If Err.Number > 0 Then
       IsBookOpened = True
     End If
End Function

Function sameNameBookOpenCheck(targetPath As String) As Boolean
'--------------------------------------------------------
'機能：指定したファイル名のブックが開かれているか確認し
'      結果をTrueかFalseで返す
'引数1：指定するファイル名
'--------------------------------------------------------
Dim ChkBook As Workbook

    On Error GoTo ErrHdl
    
    Set ChkBook = Workbooks(targetPath)
    sameNameBookOpenCheck = True
    Exit Function
    
ErrHdl:
    sameNameBookOpenCheck = False

End Function

ray88.hatenablog.com
ray88.hatenablog.com