フォルダ存在チェック

機能

対象のフォルダが存在するかチェックする。
存在する場合は確認結果にOKを、存在しない場合はNGを記載する。
※NGの場合の条件付き書式変更はシート側で設定。

シート建付け

• シート名
  フォルダ存在確認
• シート構成
  • 起点
    • No　→　A4
    • パス　→　B4
    • 確認結果　→　C4
    • ※処理内でJ列を一時使用する。

ソースコード

Module1

• 共通設定

'シート名
Public Const SHEET_NAME_FOLDER_EXISTS_CHK = "フォルダ存在確認"
'オブジェクト
Public Const FILE_SYSTEM_OBJECT = "Scripting.FileSystemObject"

• 処理

'***** フォルダ存在確認 *****
Sub FolderExistCheck()

    '行数
    Const START_WORK_ROW = 4
    '列数
    Const NO_COL = 1
    Const PATH_COL = 2
    Const RESULT_COL = 3
    Const PATH_BKUP_COL = 10
    '文言
    Const CHECK_RESULT_OK = "OK"
    Const CHECK_RESULT_NG = "NG"
    Const END_MESSAGE = "チェック完了"

    'No 初期化
    Dim cntNo As Long
    cntNo = 1
    'パス 初期化
    Dim tmpPath As String
    tmpPath = ""


    '処理前アクション
    StartAction SHEET_NAME_FOLDER_EXISTS_CHK
    
    
    '最大行取得
    Dim maxRow As Long
    maxRow = GetMaxRow(SHEET_NAME_FOLDER_EXISTS_CHK, PATH_COL)
    
    
    'パス 一時対比
    Range(Cells(START_WORK_ROW, PATH_COL), Cells(maxRow, PATH_COL)).Copy _
        Cells(START_WORK_ROW, PATH_BKUP_COL)
    

    '既存データ 削除
    ClearContents SHEET_NAME_FOLDER_EXISTS_CHK, START_WORK_ROW, Rows.Count, NO_COL, RESULT_COL


    'パス 復元
    Range(Cells(START_WORK_ROW, PATH_BKUP_COL), Cells(maxRow, PATH_BKUP_COL)).Copy _
        Cells(START_WORK_ROW, PATH_COL)
    Columns(PATH_BKUP_COL).Clear
       
    
    'フォルダ存在確認
    Dim i As Long
    
    For i = START_WORK_ROW To maxRow
    
        'No挿入
        Cells(i, NO_COL).Value = cntNo
        
        '存在チェック
        tmpPath = Cells(i, PATH_COL).Value
        If Dir(tmpPath, vbDirectory) <> "" Then
            Cells(i, RESULT_COL).Value = CHECK_RESULT_OK
        Else
            Cells(i, RESULT_COL).Value = CHECK_RESULT_NG
        End If
        
        'No更新
        cntNo = cntNo + 1
        
    Next i

    '処理後アクション
    EndAction SHEET_NAME_FOLDER_EXISTS_CHK, END_MESSAGE

End Sub

Module2

'■ ■ ■　よく使う処理　■ ■ ■

'***** 処理前アクション *****
'機能：処理開始前にExcelの描画を止める（任意）
Sub StartAction(ByVal sheetName As String, Optional ByVal ScreenUpdateFlag As Boolean = True)

    ThisWorkbook.Activate
    
    '描画停止
    If ScreenUpdateFlag = False Then
        Application.ScreenUpdating = ScreenUpdateFlag
    End If
    
    '対象シート 有効化
    Worksheets(sheetName).Activate

End Sub


'***** 処理後アクション *****
'機能：① Excelの描画を再開させる。
'　　：② [Ctrl + HOME] を押下した位置にカーソルを移動させる。
'　　：③ 終了メッセージを表示させる。
Sub EndAction(ByVal sheetName As String, ByVal endMessage As String)

    ThisWorkbook.Activate
    
    '描画再開
    Application.ScreenUpdating = True
    
    '対象シート 有効化
    Sheets(sheetName).Activate
    
    'Ctrl + HOMEの位置にカーソル移動
    With ActiveWindow
        ActiveWindow.ActiveSheet.Cells(.SplitRow + 1, .SplitColumn + 1).Activate
    End With
    
    '終了メッセージ 表示
    MsgBox endMessage

End Sub


'***** 最大行 取得 *****
'機能：最大行を取得する。
Function GetMaxRow(ByVal targetSheetName As String, ByVal targetCol As Long) As Long

    GetMaxRow = Sheets(targetSheetName).Cells(Rows.Count, targetCol).End(xlUp).Row

End Function


'***** 対象範囲 クリア *****
'機能：対象範囲の値のみを削除する。
Sub ClearContents(ByVal sheetName As String, ByVal startRow As Long, ByVal endRow As Long, ByVal startCol As Long, ByVal endCol As Long)

    Sheets(sheetName).Range( _
        Cells(startRow, startCol), Cells(endRow, endCol) _
    ).ClearContents

End Sub

ソースコードの全量は こちら
※転記漏れがあるかもしれないので。