【VBA】日付をキーにした複数ファイルの収集

処理の流れ

設定シート（Excel）から条件を読み込み → バリデーション → ネットワーク上のフォルダをスキャン → 条件に合うPDFをローカルにコピー → ログ記録、という一連の流れです。

スキャンの仕組み

まず Dir("*.pdf") でファイル名だけを高速に一括取得し、次にファイル名が除外パターン（LL* など）に一致するものをスキップ。残ったファイルだけ FSO.GetFile で作成日を取得して日付範囲内かチェックします。除外パターンに一致したファイルはFSO呼び出し自体をスキップするので、ネットワーク越しのアクセスを減らせます。

安全対策

コピー先が \\ で始まるネットワークパスだとエラーで停止（共有フォルダへの誤コピー防止）。実行前に対象ファイル一覧・件数・除外件数を確認ダイアログで表示し、デフォルトが「いいえ」なので手が滑っても実行されません。

設定シートで指定できる項目

コピー元パス、コピー先ベースパス、日付フォルダ名（2026_0302 等）、ファイルパターン、作成日 From/To、サブフォルダ検索（デフォルトOFF）、除外ファイル名パターン（複数指定可）の7項目です。

ログ

実行ごとに「ログ」シートへ追記され、各ファイルの成功/失敗とエラー内容が記録されます。

PDFコピーツールダウンロード

'==============================================================================
' PDFデータ コピーツール
'
' 機能: 設定シートの条件に基づき、コピー元フォルダから対象ファイルを
'       コピー先のローカルフォルダへコピーする。
'
' 高速化: Dir()でファイル名を一括取得後、FSO.GetFileで作成日チェック
' 安全性: コピー先ローカル確認、実行前確認ダイアログ、ログ記録
'==============================================================================
Option Explicit
Option Compare Text  ' 大文字小文字を区別しない（Like演算子・文字列比較）

Private m_fso As Object
Private m_copyList As Collection
Private m_excludePatterns() As String
Private m_excludeCount As Long
Private m_fileExt As String
Private m_dateFrom As Date
Private m_dateTo As Date
Private m_totalScanned As Long
Private m_excludedFileCount As Long  ' 除外されたファイル数カウント

'==============================================================================
' メインマクロ: PDFデータコピー実行
'==============================================================================
Public Sub PDFデータコピー実行()

    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("設定")
    On Error GoTo 0
    If ws Is Nothing Then
        MsgBox "「設定」シートが見つかりません。", vbCritical, "エラー"
        Exit Sub
    End If

    '----------------------------------------------------------------------
    ' 設定値の読込
    '----------------------------------------------------------------------
    Dim srcPath As String:    srcPath = Trim(CStr(ws.Range("C4").Value))
    Dim dstBase As String:    dstBase = Trim(CStr(ws.Range("C5").Value))
    Dim dateFolder As String: dateFolder = Trim(CStr(ws.Range("C6").Value))
    m_fileExt = Trim(CStr(ws.Range("C7").Value))
    If m_fileExt = "" Then m_fileExt = "*.pdf"

    ' 日付の読込と検証
    If Not IsDate(ws.Range("C8").Value) Then
        MsgBox "作成日（From）に有効な日付を入力してください。", vbCritical, "入力エラー"
        ws.Range("C8").Select
        Exit Sub
    End If
    If Not IsDate(ws.Range("C9").Value) Then
        MsgBox "作成日（To）に有効な日付を入力してください。", vbCritical, "入力エラー"
        ws.Range("C9").Select
        Exit Sub
    End If
    m_dateFrom = CDate(ws.Range("C8").Value)
    m_dateTo = CDate(ws.Range("C9").Value)

    Dim recurse As Boolean
    On Error Resume Next
    recurse = CBool(ws.Range("C10").Value)
    On Error GoTo 0

    '----------------------------------------------------------------------
    ' 除外ファイル名パターンの読込
    '----------------------------------------------------------------------
    m_excludeCount = 0
    ReDim m_excludePatterns(0 To 99)
    Dim r As Long: r = 13
    Do While Trim(CStr(ws.Cells(r, 3).Value)) <> ""
        m_excludePatterns(m_excludeCount) = Trim(CStr(ws.Cells(r, 3).Value))
        m_excludeCount = m_excludeCount + 1
        r = r + 1
        If m_excludeCount > 99 Then Exit Do
    Loop

    '----------------------------------------------------------------------
    ' バリデーション
    '----------------------------------------------------------------------
    ' パス末尾の \ を除去
    If Len(srcPath) > 0 And Right(srcPath, 1) = "\" Then srcPath = Left(srcPath, Len(srcPath) - 1)
    If Len(dstBase) > 0 And Right(dstBase, 1) = "\" Then dstBase = Left(dstBase, Len(dstBase) - 1)

    ' 必須項目チェック
    If srcPath = "" Then
        MsgBox "コピー元フォルダが未入力です。", vbCritical, "入力エラー"
        ws.Range("C4").Select: Exit Sub
    End If
    If dstBase = "" Then
        MsgBox "コピー先ベースフォルダが未入力です。", vbCritical, "入力エラー"
        ws.Range("C5").Select: Exit Sub
    End If
    If dateFolder = "" Then
        MsgBox "日付フォルダ名が未入力です。", vbCritical, "入力エラー"
        ws.Range("C6").Select: Exit Sub
    End If

    ' コピー先がローカルか確認（ネットワークパス \\... を拒否）
    If Left(dstBase, 2) = "\\" Then
        MsgBox "【安全確認エラー】" & vbCrLf & vbCrLf & _
               "コピー先にネットワークパス（\\...）が指定されています。" & vbCrLf & _
               "誤って共有フォルダに保存しないよう、" & vbCrLf & _
               "コピー先はローカルフォルダ（例: C:\Data）を指定してください。", _
               vbCritical, "安全確認エラー"
        ws.Range("C5").Select
        Exit Sub
    End If
    If Len(dstBase) < 2 Or Mid(dstBase, 2, 1) <> ":" Then
        MsgBox "コピー先はドライブレター付きのローカルパスを指定してください。" & vbCrLf & _
               "例: C:\Users\ユーザー名\Desktop\Archive", vbCritical, "入力エラー"
        ws.Range("C5").Select
        Exit Sub
    End If

    ' 日付の整合性チェック
    If m_dateFrom > m_dateTo Then
        MsgBox "作成日の From が To より後の日付になっています。", vbCritical, "入力エラー"
        Exit Sub
    End If

    ' コピー元の存在確認
    Set m_fso = CreateObject("Scripting.FileSystemObject")
    If Not m_fso.FolderExists(srcPath) Then
        MsgBox "コピー元フォルダが見つかりません:" & vbCrLf & srcPath, vbCritical, "エラー"
        Exit Sub
    End If

    '----------------------------------------------------------------------
    ' ファイルスキャン（高速化: Dir()で名前取得 → FSO で作成日チェック）
    '----------------------------------------------------------------------
    Set m_copyList = New Collection
    m_totalScanned = 0
    m_excludedFileCount = 0

    Application.StatusBar = "ファイルスキャン中... (ネットワークフォルダの場合、時間がかかることがあります)"
    DoEvents

    Dim startTime As Double: startTime = Timer

    ScanFolder srcPath, recurse

    Dim elapsed As Double: elapsed = Timer - startTime
    Application.StatusBar = False

    '----------------------------------------------------------------------
    ' スキャン結果の確認
    '----------------------------------------------------------------------
    If m_copyList.Count = 0 Then
        MsgBox "条件に一致するファイルが見つかりませんでした。" & vbCrLf & vbCrLf & _
               "スキャンファイル数: " & m_totalScanned & vbCrLf & _
               "スキャン時間: " & Format(elapsed, "0.0") & " 秒" & vbCrLf & vbCrLf & _
               "設定を確認してください:" & vbCrLf & _
               "  - ファイルパターン: " & m_fileExt & vbCrLf & _
               "  - 作成日範囲: " & Format(m_dateFrom, "yyyy/mm/dd") & " ～ " & Format(m_dateTo, "yyyy/mm/dd"), _
               vbInformation, "結果"
        Exit Sub
    End If

    Dim dstPath As String: dstPath = dstBase & "\" & dateFolder

    '----------------------------------------------------------------------
    ' 確認ダイアログ（ファイル一覧表示）
    '----------------------------------------------------------------------
    Dim msg As String
    msg = "以下の条件でコピーを実行します。よろしいですか？" & vbCrLf & vbCrLf
    msg = msg & "【コピー元】" & vbCrLf & "  " & srcPath & vbCrLf
    msg = msg & "【コピー先】" & vbCrLf & "  " & dstPath & vbCrLf
    msg = msg & "【対象】 " & m_copyList.Count & " 件 （スキャン: " & m_totalScanned & " 件 / " & Format(elapsed, "0.0") & "秒）" & vbCrLf
    msg = msg & "【作成日】 " & Format(m_dateFrom, "yyyy/mm/dd") & " ～ " & Format(m_dateTo, "yyyy/mm/dd") & vbCrLf
    If m_excludeCount > 0 Then
        msg = msg & "【除外ファイル】 " & m_excludedFileCount & " 件除外済 (パターン: "
        Dim p As Long
        For p = 0 To m_excludeCount - 1
            If p > 0 Then msg = msg & ", "
            msg = msg & m_excludePatterns(p)
        Next p
        msg = msg & ")" & vbCrLf
    End If
    msg = msg & vbCrLf & "--- 対象ファイル ---" & vbCrLf

    Dim i As Long
    Dim maxShow As Long: maxShow = 25
    For i = 1 To WorksheetFunction.Min(m_copyList.Count, maxShow)
        msg = msg & "  " & m_fso.GetFileName(CStr(m_copyList(i))) & vbCrLf
    Next i
    If m_copyList.Count > maxShow Then
        msg = msg & "  ... 他 " & (m_copyList.Count - maxShow) & " ファイル" & vbCrLf
    End If

    If MsgBox(msg, vbYesNo + vbQuestion + vbDefaultButton2, "コピー実行確認") <> vbYes Then
        MsgBox "キャンセルしました。", vbInformation, "中断"
        Exit Sub
    End If

    '----------------------------------------------------------------------
    ' コピー実行
    '----------------------------------------------------------------------
    ' コピー先フォルダ作成
    If Not m_fso.FolderExists(dstPath) Then
        CreateFolderRecursive dstPath
    End If

    Dim copied As Long: copied = 0
    Dim failed As Long: failed = 0
    Dim logData As Collection
    Set logData = New Collection

    For i = 1 To m_copyList.Count
        Dim srcFile As String: srcFile = CStr(m_copyList(i))
        Dim fileName As String: fileName = m_fso.GetFileName(srcFile)
        Dim dstFile As String: dstFile = dstPath & "\" & fileName

        Application.StatusBar = "コピー中... (" & i & "/" & m_copyList.Count & ") " & fileName
        DoEvents

        On Error Resume Next
        m_fso.CopyFile srcFile, dstFile, True
        If Err.Number = 0 Then
            copied = copied + 1
            logData.Add Array(Format(Now, "yyyy/mm/dd hh:nn:ss"), "OK", fileName, srcFile, "")
        Else
            failed = failed + 1
            logData.Add Array(Format(Now, "yyyy/mm/dd hh:nn:ss"), "NG", fileName, srcFile, Err.Description)
            Err.Clear
        End If
        On Error GoTo 0
    Next i

    Application.StatusBar = False

    '----------------------------------------------------------------------
    ' ログ書込
    '----------------------------------------------------------------------
    WriteLog ws, logData, srcPath, dstPath

    '----------------------------------------------------------------------
    ' 完了メッセージ
    '----------------------------------------------------------------------
    Dim icon As VbMsgBoxStyle
    icon = IIf(failed > 0, vbExclamation, vbInformation)

    Dim doneMsg As String
    doneMsg = "コピー完了！" & vbCrLf & vbCrLf & _
              "成功: " & copied & " ファイル" & vbCrLf & _
              "失敗: " & failed & " ファイル" & vbCrLf & vbCrLf & _
              "コピー先: " & dstPath & vbCrLf & vbCrLf & _
              "コピー先フォルダを開きますか？"

    If MsgBox(doneMsg, vbYesNo + icon, "処理完了") = vbYes Then
        Shell "explorer.exe """ & dstPath & """", vbNormalFocus
    End If

    Set m_fso = Nothing
    Set m_copyList = Nothing

End Sub

'==============================================================================
' フォルダスキャン（再帰対応）
' Dir() でファイル名を一括取得し、FSO.GetFile で作成日チェック
' ※ Dir() はネストできないため、ファイル名→サブフォルダ名の順に収集してから処理
'==============================================================================
Private Sub ScanFolder(ByVal folderPath As String, ByVal recurse As Boolean)

    '--- ステップ1: Dir() でファイル名を高速収集 ---
    Dim fileNames As Collection
    Set fileNames = New Collection

    On Error Resume Next
    Dim fn As String
    fn = Dir(folderPath & "\" & m_fileExt)
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo 0
        Exit Sub
    End If
    On Error GoTo 0

    Do While fn <> ""
        fileNames.Add fn
        fn = Dir()
    Loop

    '--- ステップ2: ファイル名除外 → 作成日でフィルタ ---
    Dim i As Long
    Dim dateTo_end As Date
    dateTo_end = DateAdd("d", 1, m_dateTo)  ' To の日も含む（翌日未満で判定）

    For i = 1 To fileNames.Count
        m_totalScanned = m_totalScanned + 1

        ' ファイル名が除外パターンに一致 → スキップ
        If IsExcludedFile(CStr(fileNames(i))) Then
            m_excludedFileCount = m_excludedFileCount + 1
            GoTo NextFile
        End If

        Dim fullPath As String
        fullPath = folderPath & "\" & fileNames(i)

        On Error Resume Next
        Dim f As Object
        Set f = m_fso.GetFile(fullPath)
        If Err.Number = 0 Then
            Dim createdDate As Date
            createdDate = f.DateCreated
            If Err.Number = 0 Then
                If createdDate >= m_dateFrom And createdDate < dateTo_end Then
                    m_copyList.Add fullPath
                End If
            End If
        End If
        Err.Clear
        On Error GoTo 0
        Set f = Nothing

NextFile:
        ' 進捗表示（50件ごと）
        If m_totalScanned Mod 50 = 0 Then
            Application.StatusBar = "スキャン中... " & m_totalScanned & " ファイル処理 / " & m_copyList.Count & " 件該当"
            DoEvents
        End If
    Next i

    '--- ステップ3: サブフォルダ収集（再帰する場合のみ） ---
    If recurse Then
        Dim subFolders As Collection
        Set subFolders = New Collection

        ' FSO経由でサブフォルダを取得（Dir()より確実）
        On Error Resume Next
        Dim parentFolder As Object
        Set parentFolder = m_fso.GetFolder(folderPath)
        If Err.Number <> 0 Then
            Err.Clear
            On Error GoTo 0
            Exit Sub
        End If
        On Error GoTo 0

        Dim subFolder As Object
        For Each subFolder In parentFolder.SubFolders
            subFolders.Add subFolder.Name
        Next subFolder
        Set parentFolder = Nothing

        '--- ステップ4: サブフォルダを再帰処理 ---
        For i = 1 To subFolders.Count
            ScanFolder folderPath & "\" & subFolders(i), True
        Next i
    End If

End Sub

'==============================================================================
' 除外ファイル判定（Like演算子 / Option Compare Text で大文字小文字区別なし）
' ファイル名（拡張子含む）に対してパターンマッチ
'==============================================================================
Private Function IsExcludedFile(ByVal fileName As String) As Boolean
    Dim i As Long
    For i = 0 To m_excludeCount - 1
        If fileName Like m_excludePatterns(i) Then
            IsExcludedFile = True
            Exit Function
        End If
    Next i
    IsExcludedFile = False
End Function

'==============================================================================
' フォルダ再帰作成
'==============================================================================
Private Sub CreateFolderRecursive(ByVal path As String)
    If m_fso.FolderExists(path) Then Exit Sub

    Dim parent As String
    parent = m_fso.GetParentFolderName(path)
    If Not m_fso.FolderExists(parent) Then
        CreateFolderRecursive parent
    End If

    m_fso.CreateFolder path
End Sub

'==============================================================================
' ログ書込（「ログ」シートに追記）
'==============================================================================
Private Sub WriteLog(ByVal wsSetting As Worksheet, ByVal logData As Collection, _
                     ByVal srcPath As String, ByVal dstPath As String)

    Dim wsLog As Worksheet
    On Error Resume Next
    Set wsLog = ThisWorkbook.Sheets("ログ")
    On Error GoTo 0

    ' ログシートがなければ作成
    If wsLog Is Nothing Then
        Set wsLog = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsLog.Name = "ログ"
        wsLog.Range("A1").Value = "日時"
        wsLog.Range("B1").Value = "結果"
        wsLog.Range("C1").Value = "ファイル名"
        wsLog.Range("D1").Value = "フルパス"
        wsLog.Range("E1").Value = "備考"
        wsLog.Range("A1:E1").Font.Bold = True
    End If

    ' AutoFilterが有効な場合は解除（書込エラー防止）
    On Error Resume Next
    If wsLog.AutoFilterMode Then wsLog.AutoFilterMode = False
    On Error GoTo 0

    ' 最終行の次から書込
    Dim startRow As Long
    startRow = wsLog.Cells(wsLog.Rows.Count, 1).End(xlUp).Row + 1
    If startRow < 2 Then startRow = 2

    ' 空行を1行挟む（2回目以降の実行時に見やすく）
    If startRow > 2 Then startRow = startRow + 1

    ' 実行情報ヘッダー（先頭に = を使わない → 数式誤認防止）
    wsLog.Cells(startRow, 1).Value = "[実行] " & Format(Now, "yyyy/mm/dd hh:nn:ss")
    wsLog.Cells(startRow, 2).Value = srcPath
    wsLog.Cells(startRow, 3).Value = dstPath
    wsLog.Range(wsLog.Cells(startRow, 1), wsLog.Cells(startRow, 5)).Font.Bold = True
    wsLog.Range(wsLog.Cells(startRow, 1), wsLog.Cells(startRow, 5)).Interior.Color = RGB(230, 230, 230)
    startRow = startRow + 1

    ' 各ファイルのログ
    Dim i As Long
    For i = 1 To logData.Count
        Dim d As Variant: d = logData(i)
        wsLog.Cells(startRow, 1).Value = d(0)  ' 日時
        wsLog.Cells(startRow, 2).Value = d(1)  ' 結果
        wsLog.Cells(startRow, 3).Value = d(2)  ' ファイル名
        wsLog.Cells(startRow, 4).Value = d(3)  ' フルパス
        wsLog.Cells(startRow, 5).Value = d(4)  ' 備考

        ' NG の場合は赤文字
        If d(1) = "NG" Then
            wsLog.Range(wsLog.Cells(startRow, 1), wsLog.Cells(startRow, 5)).Font.Color = RGB(204, 0, 0)
        End If

        startRow = startRow + 1
    Next i

    ' 列幅調整
    wsLog.Columns("A:E").AutoFit

    ' 設定シートに戻る
    wsSetting.Activate

End Sub

'==============================================================================
' ユーティリティ: 日付フォルダ名を今日の日付に更新
'==============================================================================
Public Sub 日付フォルダ名を今日に更新()
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("設定")
    On Error GoTo 0
    If ws Is Nothing Then Exit Sub

    ws.Range("C6").Value = Format(Date, "yyyy\_mmdd")
    MsgBox "日付フォルダ名を「" & ws.Range("C6").Value & "」に更新しました。", vbInformation, "更新完了"
End Sub

'==============================================================================
' ユーティリティ: コピー先フォルダを開く
'==============================================================================
Public Sub コピー先フォルダを開く()
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("設定")
    On Error GoTo 0
    If ws Is Nothing Then Exit Sub

    Dim dstPath As String
    dstPath = Trim(CStr(ws.Range("C5").Value)) & "\" & Trim(CStr(ws.Range("C6").Value))

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    If fso.FolderExists(dstPath) Then
        Shell "explorer.exe """ & dstPath & """", vbNormalFocus
    Else
        MsgBox "フォルダが見つかりません:" & vbCrLf & dstPath, vbExclamation, "エラー"
    End If
End Sub

コメント

タイトルとURLをコピーしました