【VBA】複数ファイルの収集

処理の流れ

マクロ FileCopyMain を実行すると、以下の順番で動きます。

1. 入力チェック シートのB3（コピー元）とB4（コピー先）を読み取り、空欄がないか、コピー先が C:\ や D:\ などローカルドライブかを確認します。\\server\... のようなネットワークパスが指定されていたらブロックします。

2. フォルダ存在チェック コピー元フォルダが実際に存在するか確認します。コピー先フォルダが存在しない場合は「作成しますか？」と聞いてきます。

3. コピー元のファイル一覧をキャッシュ コピー元フォルダの中身を一度だけ全部読み込んで、メモリ上のリスト（Dictionary）に保存します。これが「キャッシュ」です（詳しくは後述）。

4. 実行確認ダイアログ コピー元、コピー先、対象ファイル数をまとめたメッセージボックスが出ます。「はい」を押さない限りコピーは始まりません。

5. 上書き確認 コピー先に同名ファイルがある場合、その一覧を表示して「上書きしてよろしいですか？」と確認します。

6. コピー実行 ファイルを1つずつコピーしながら、ステータスバーに進捗（「3/20 コピー中…」のように）を表示します。各ファイルの結果はC列に緑（成功）または赤（失敗・見つからない）で書き込まれます。

7. 完了報告 成功数・失敗数をまとめたメッセージが表示されます。

Dictionaryの検索

Dir()でフォルダ内のファイル名を1つずつ取得してDictionaryに入れていく処理ですが、これはファイル名の文字列を読み取るだけで、ファイルの中身を開いたりしません。100個程度のファイル名取得はネットワーク越しでも1回の通信で済むことがほとんどなので、体感としてはエクスプローラでそのフォルダを開くのと同じくらいの待ち時間です。

キャッシュ後の検索は、Dictionaryがハッシュテーブルという仕組みで動いているため、100個だろうが1000個だろうが1回の検索はほぼ一瞬です。20ファイル分の検索を合わせてもミリ秒レベルで終わります。

ファイルコピーツールダウンロード
VBAコードダウンロード
'=============================================================
' ファイルコピーツール VBAマクロ
' 使い方: Alt+F11 → 挿入 → 標準モジュール → このコードを貼り付け
'=============================================================

Option Explicit

' --- 定数 ---
Private Const SHEET_NAME As String = "ファイルコピー"
Private Const ROW_SRC As Long = 3       ' コピー元パス行
Private Const ROW_DST As Long = 4       ' コピー先パス行
Private Const COL_PATH As Long = 2      ' パス列 (B列)
Private Const ROW_FILE_START As Long = 8 ' ファイル名開始行
Private Const COL_NO As Long = 1        ' No.列 (A列)
Private Const COL_FILE As Long = 2      ' ファイル名列 (B列)
Private Const COL_RESULT As Long = 3    ' 結果列 (C列)

'=============================================================
' メインルーチン
'=============================================================
Public Sub FileCopyMain()

    Dim ws As Worksheet
    Dim srcFolder As String
    Dim dstFolder As String
    Dim fileNames() As String
    Dim fileCount As Long
    Dim i As Long

    On Error GoTo ErrHandler

    ' シート取得
    Set ws = ThisWorkbook.Worksheets(SHEET_NAME)

    ' パス取得・整形
    srcFolder = Trim(CStr(ws.Cells(ROW_SRC, COL_PATH).Value))
    dstFolder = Trim(CStr(ws.Cells(ROW_DST, COL_PATH).Value))

    ' 末尾に \ を付与
    If Right(srcFolder, 1) <> "\" Then srcFolder = srcFolder & "\"
    If Right(dstFolder, 1) <> "\" Then dstFolder = dstFolder & "\"

    ' --- バリデーション ---

    ' 空チェック
    If srcFolder = "\" Or dstFolder = "\" Then
        MsgBox "コピー元フォルダとコピー先フォルダを入力してください。", vbExclamation, "入力エラー"
        Exit Sub
    End If

    ' コピー先がローカルドライブかチェック
    If Not IsLocalPath(dstFolder) Then
        MsgBox "コピー先はローカルドライブ（C:\, D:\ 等）を指定してください。" & vbCrLf & _
               "ネットワークパス（\\で始まるパス）は指定できません。" & vbCrLf & vbCrLf & _
               "現在の指定: " & dstFolder, vbExclamation, "コピー先エラー"
        Exit Sub
    End If

    ' コピー元フォルダ存在チェック
    If Dir(srcFolder, vbDirectory) = "" Then
        MsgBox "コピー元フォルダが見つかりません:" & vbCrLf & srcFolder, vbExclamation, "パスエラー"
        Exit Sub
    End If

    ' コピー先フォルダ存在チェック
    If Dir(dstFolder, vbDirectory) = "" Then
        Dim ans As VbMsgBoxResult
        ans = MsgBox("コピー先フォルダが存在しません。作成しますか？" & vbCrLf & dstFolder, _
                     vbYesNo + vbQuestion, "フォルダ作成")
        If ans = vbYes Then
            MkDirRecursive dstFolder
        Else
            Exit Sub
        End If
    End If

    ' ファイル名一覧を取得
    fileCount = GetFileList(ws, fileNames)

    If fileCount = 0 Then
        MsgBox "コピー対象ファイルが1つも入力されていません。", vbExclamation, "入力エラー"
        Exit Sub
    End If

    ' 結果列クリア
    ClearResults ws

    ' --- 実行前確認 ---
    Dim confirmMsg As String
    confirmMsg = "以下の内容でファイルコピーを実行します。" & vbCrLf & vbCrLf
    confirmMsg = confirmMsg & "【コピー元】" & vbCrLf & srcFolder & vbCrLf & vbCrLf
    confirmMsg = confirmMsg & "【コピー先】" & vbCrLf & dstFolder & vbCrLf & vbCrLf
    confirmMsg = confirmMsg & "【対象ファイル数】" & fileCount & " 件" & vbCrLf & vbCrLf
    confirmMsg = confirmMsg & "実行してよろしいですか？"

    If MsgBox(confirmMsg, vbYesNo + vbQuestion, "実行確認") <> vbYes Then
        Exit Sub
    End If

    ' --- コピー元ファイル一覧をキャッシュ（ネットワーク負荷軽減） ---
    ' ネットワークドライブは Dir() が遅いため、1回だけ列挙してDictionaryに格納
    Application.StatusBar = "コピー元フォルダを読み込み中（ネットワークドライブの場合、時間がかかります）..."
    DoEvents

    Dim srcFileDict As Object
    Set srcFileDict = CreateObject("Scripting.Dictionary")
    srcFileDict.CompareMode = vbTextCompare  ' 大文字小文字を無視

    Dim dirFile As String
    dirFile = Dir(srcFolder & "*.*")
    Do While dirFile <> ""
        If Not srcFileDict.Exists(LCase(dirFile)) Then
            srcFileDict.Add LCase(dirFile), dirFile  ' Key=小文字, Value=実際の名前
        End If
        dirFile = Dir()
    Loop
    Application.StatusBar = False

    ' --- 既存ファイル上書き確認 ---
    Dim overwriteList As String
    Dim overwriteCount As Long
    overwriteCount = 0
    overwriteList = ""

    For i = 0 To fileCount - 1
        Dim actualName As String
        actualName = FindInCache(srcFileDict, fileNames(i))
        If actualName <> "" Then
            If Dir(dstFolder & actualName) <> "" Then
                overwriteCount = overwriteCount + 1
                overwriteList = overwriteList & "  " & actualName & vbCrLf
            End If
        End If
    Next i

    If overwriteCount > 0 Then
        Dim owMsg As String
        owMsg = "コピー先に以下の " & overwriteCount & " ファイルが既に存在します。" & vbCrLf
        owMsg = owMsg & "上書きしてよろしいですか？" & vbCrLf & vbCrLf
        owMsg = owMsg & overwriteList

        If MsgBox(owMsg, vbYesNo + vbExclamation, "上書き確認") <> vbYes Then
            Exit Sub
        End If
    End If

    ' --- コピー実行 ---
    Application.StatusBar = "ファイルコピー処理中..."
    Application.ScreenUpdating = False

    Dim successCount As Long, failCount As Long, skipCount As Long
    successCount = 0: failCount = 0: skipCount = 0

    For i = 0 To fileCount - 1
        Dim rowNum As Long
        rowNum = ROW_FILE_START + i

        DoEvents  ' UIの応答を維持
        Application.StatusBar = "コピー中... (" & (i + 1) & "/" & fileCount & ") " & fileNames(i)

        ' キャッシュから大文字小文字を無視して検索
        actualName = FindInCache(srcFileDict, fileNames(i))

        If actualName = "" Then
            ' ファイルが見つからない
            SetResult ws, rowNum, "見つかりません", RGB(200, 0, 0)
            failCount = failCount + 1
        Else
            ' コピー実行
            On Error Resume Next
            FileCopy srcFolder & actualName, dstFolder & actualName

            If Err.Number = 0 Then
                SetResult ws, rowNum, "コピー完了", RGB(0, 128, 0)
                successCount = successCount + 1
            Else
                SetResult ws, rowNum, "エラー: " & Err.Description, RGB(200, 0, 0)
                failCount = failCount + 1
                Err.Clear
            End If
            On Error GoTo ErrHandler
        End If
    Next i

    Application.ScreenUpdating = True
    Application.StatusBar = False

    ' --- 完了メッセージ ---
    Dim resultMsg As String
    resultMsg = "ファイルコピーが完了しました。" & vbCrLf & vbCrLf
    resultMsg = resultMsg & "  成功: " & successCount & " 件" & vbCrLf
    resultMsg = resultMsg & "  失敗: " & failCount & " 件" & vbCrLf
    resultMsg = resultMsg & "  合計: " & fileCount & " 件"

    If failCount > 0 Then
        MsgBox resultMsg, vbExclamation, "完了（一部エラーあり）"
    Else
        MsgBox resultMsg, vbInformation, "完了"
    End If

    Exit Sub

ErrHandler:
    Application.ScreenUpdating = True
    Application.StatusBar = False
    MsgBox "予期しないエラーが発生しました。" & vbCrLf & vbCrLf & _
           "エラー番号: " & Err.Number & vbCrLf & _
           "内容: " & Err.Description, vbCritical, "エラー"
End Sub

'=============================================================
' ローカルパス判定（ドライブレターで始まるか）
'=============================================================
Private Function IsLocalPath(ByVal path As String) As Boolean
    IsLocalPath = False
    If Len(path) >= 2 Then
        Dim firstChar As String
        firstChar = UCase(Left(path, 1))
        If firstChar >= "A" And firstChar <= "Z" Then
            If Mid(path, 2, 1) = ":" Then
                ' ネットワークドライブのマッピングも除外したい場合は
                ' 以下のチェックを有効にしてください
                ' （ただし、マッピングされたドライブはローカル扱いにする場合はコメントアウト）
                '
                ' Dim drv As String
                ' drv = Left(path, 2)
                ' Dim fso As Object
                ' Set fso = CreateObject("Scripting.FileSystemObject")
                ' If fso.DriveExists(drv) Then
                '     If fso.GetDrive(drv).DriveType = 3 Then ' Network
                '         IsLocalPath = False
                '         Exit Function
                '     End If
                ' End If

                IsLocalPath = True
            End If
        End If
    End If
End Function

'=============================================================
' キャッシュ済みDictionaryからファイルを検索（大文字小文字無視）
' ネットワークドライブへのDir()は1回だけに抑えるための仕組み
'=============================================================
Private Function FindInCache(ByVal dict As Object, ByVal targetName As String) As String
    Dim key As String
    key = LCase(Trim(targetName))
    If dict.Exists(key) Then
        FindInCache = dict(key)  ' 実際のファイル名を返す
    Else
        FindInCache = ""
    End If
End Function

'=============================================================
' ファイル名一覧を取得
'=============================================================
Private Function GetFileList(ByVal ws As Worksheet, ByRef fileNames() As String) As Long
    Dim count As Long
    count = 0
    Dim row As Long
    row = ROW_FILE_START

    ' まず件数をカウント
    Do While row <= 1000  ' 安全上限
        Dim val As Variant
        val = ws.Cells(row, COL_FILE).Value
        If IsEmpty(val) Or Trim(CStr(val)) = "" Then
            Exit Do
        End If
        count = count + 1
        row = row + 1
    Loop

    If count = 0 Then
        GetFileList = 0
        Exit Function
    End If

    ReDim fileNames(0 To count - 1)

    Dim i As Long
    For i = 0 To count - 1
        fileNames(i) = Trim(CStr(ws.Cells(ROW_FILE_START + i, COL_FILE).Value))
    Next i

    GetFileList = count
End Function

'=============================================================
' 結果列をクリア
'=============================================================
Private Sub ClearResults(ByVal ws As Worksheet)
    Dim row As Long
    row = ROW_FILE_START
    Do While row <= 1000
        If IsEmpty(ws.Cells(row, COL_FILE).Value) Or Trim(CStr(ws.Cells(row, COL_FILE).Value)) = "" Then
            Exit Do
        End If
        ws.Cells(row, COL_RESULT).Value = ""
        ws.Cells(row, COL_RESULT).Font.Color = RGB(0, 0, 0)
        row = row + 1
    Loop
End Sub

'=============================================================
' 結果セルに値と色を設定
'=============================================================
Private Sub SetResult(ByVal ws As Worksheet, ByVal row As Long, ByVal text As String, ByVal clr As Long)
    ws.Cells(row, COL_RESULT).Value = text
    ws.Cells(row, COL_RESULT).Font.Color = clr
End Sub

'=============================================================
' フォルダを再帰的に作成
'=============================================================
Private Sub MkDirRecursive(ByVal path As String)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.FolderExists(path) Then
        ' 親フォルダを先に作成
        Dim parentPath As String
        parentPath = fso.GetParentFolderName(path)
        If Not fso.FolderExists(parentPath) Then
            MkDirRecursive parentPath
        End If
        fso.CreateFolder path
    End If
End Sub

コメント

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