【VBA】フォルダ更新確認自動化ツール

本日はフォルダ内へサブフォルダが追加されたかを日々確認できるツールを作成してみました。

目次

ツール作成の背景

私の関わる業務では作業者の方がデータ取得→サーバへ格納をしていただいておりました。
そのデータを日々確認していたのですが、毎回フォルダを見に行くのが面倒で、、、
どうにか自動化できないかと試行錯誤した結果が今回のツールになります。

同じ悩みを持っている方がいらっしゃればご活用いただければと思います。

ツールの考え方

データ格納先が今後増えること、そもそも現時点で複数ある事から
Excel上で親フォルダの数とパスを指定してサブフォルダの名前やパスを取得しに行くツールとしています。
あるルールさえ守ればVBAコードのメンテナンスフリーを目指しています。

動作前

動作後

更新箇所の取得＆見える化ができました。

ツール全体像

頑張った点を記載したうえでの、ソースコードの全体像になります。
あ、Microsoft Scripting Runtimeのライブラリを有効かしないと使えませんのでご注意を…
（その辺は後々ブログにしていこうと思います。）

コードの説明

シート上で繰り返し数決定

変数：pFlCntにエクセルシートから親フォルダ数を取得し For文の繰り返しに使用しています。
→狙いはコード上での繰り返し数変更をしなくてよくなるように。

追加されたフォルダ名のみ処理

myObjでmyRangeの範囲をFindで検索し、一致した場合は更新しないようにしています。
→新規に追加されたフォルダのみを取得することが目的のためです。

通常フォルダのみの取得

変数：folderAttributesが 16の時のみ処理へ入るようにしています。
→通常フォルダのみを取得することを目的としているためです。

更新箇所通知

msgへchangeflg()がTrueとなった親フォルダ名を格納し、MsgBoxでどの親フォルダに更新があったかを通知しています。
→ユーザとの対話のためのつもり…です。

Sub GetSubFolderName()

    Dim fso As FileSystemObject
    Set fso = New FileSystemObject

    Dim pFolder As Folder: Dim fl As Folder
    Dim pFolderName As String: Dim folderName As String: Dim folderPath As String
    
    Dim pFlCnt As Long: Dim i As Long: Dim j As Long: Dim cnt As Long
    Dim tSRow As Long: Dim tERow As Long: Dim tSCol As Long: Dim folderAttributes As Long
    Dim mywb As Workbook: Dim myws As Worksheet
    
    Dim myRange As Range: Dim myObj As Range
    
    Dim changeflg() As Boolean
    Dim msg As String
    
    Set mywb = ThisWorkbook
    Set myws = mywb.Worksheets("main")
    
    pFlCnt = myws.Cells(2, 4).Value
    
    ReDim changeflg(pFlCnt) As Boolean
    
    For i = 1 To pFlCnt
        j = 0: tSRow = 6: tSCol = 5 * (i - 1) + 2               '初期化
        tERow = myws.Cells(tSRow, tSCol + 1).End(xlDown).Row    'セルの一番下の行取得
        
        '初期空欄時
        If tERow = Rows.Count Then
            tERow = 6
            cnt = 0
        Else
            cnt = myws.Cells(tERow, tSCol).Value
        End If
        
        pFolderName = myws.Cells(4, 5 * (i - 1) + 4).Value      '親フォルダのパス取得
        Set pFolder = fso.GetFolder(pFolderName)                '親フォルダを取得

        '検索対象設定
        Set myRange = myws.Range(myws.Cells(tSRow, tSCol + 1), myws.Cells(tERow, tSCol + 1))
        myws.Cells(tSRow, tSCol).Resize(tERow, 4).Interior.ColorIndex = 0
        
        For Each fl In pFolder.SubFolders                       'サブフォルダの一覧を取得
            folderName = fl.Name                                'フォルダ名の取得
            folderPath = fl.Path                                'サブフォルダパスの取得
            folderAttributes = fl.Attributes                    'サブフォルダの属性取得

            Set myObj = myRange.Find(folderName, LookAt:=xlWhole)

            If folderAttributes = 16 Then
                '更新判断
                If myObj Is Nothing Then
                'cnt,フォルダ名,フォルダパス記載
                    cnt = cnt + 1
                    j = j + 1
                    myws.Cells(tERow + j, tSCol).Value = cnt
                    myws.Cells(tERow + j, tSCol + 1).Value = folderName
                    myws.Cells(tERow + j, tSCol + 2).Value = folderPath
                    myws.Cells(tERow + j, tSCol + 3).Value = Date
                    '更新したセルへ色を付ける
                    myws.Cells(tERow + j, tSCol).Resize(, 4).Interior.Color = RGB(204, 255, 255)
                    
                    changeflg(i) = True                         'フラグ立てる
                End If
            End If
        Next
    Next i
    
    '更新通知
    For i = 1 To pFlCnt
        If changeflg(i) = True Then
            msg = msg & "親フォルダ" & i & "のサブフォルダに更新がありました。" & vbCrLf
        End If
    Next i
    
    If msg <> "" Then
        MsgBox (msg)
    End If
        
    ' 後始末
    Set fso = Nothing
    Set pFolder = Nothing
    Set mywb = Nothing
    Set myws = Nothing

End Sub