ファイル検査用 マクロ VBA

ファイルを対象のフォルダにコピーするマクロです

Sub CopyFilesFromCells()
    Dim fso As Object
    Dim sourcePath As String
    Dim destinationPath: String
    Dim fileName As String
    Dim sourceFile As String
    Dim destinationFile As String
    Dim ws As Worksheet
    Dim i As Long
    Dim fileFound As Boolean
    
    ' ファイルシステムオブジェクトを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' コピー元とコピー先のパスをC2とC3セルから取得
    Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を適宜変更してください
    sourcePath = ws.Range("C2").Value
    destinationPath = ws.Range("C3").Value
    
    ' B7セルから下に向かってファイル名を取得してコピー
    i = 7
    Do While ws.Range("B" & i).Value <> ""
        fileName = ws.Range("B" & i).Value
        fileFound = False
        
        ' ファイル名に拡張子が含まれているかチェック
        If InStr(fileName, ".") = 0 Then
            ' 拡張子が省略されている場合、ディレクトリ内のファイルを確認
            Dim file As Object
            For Each file In fso.GetFolder(sourcePath).Files
                If Left(file.Name, InStrRev(file.Name, ".") - 1) = fileName Then
                    fileName = file.Name
                    fileFound = True
                    Exit For
                End If
            Next file
        Else
            fileFound = True
        End If
        
        If fileFound Then
            sourceFile = fso.BuildPath(sourcePath, fileName)
            destinationFile = fso.BuildPath(destinationPath, fileName)
            
            ' ファイルをコピー
            On Error Resume Next ' エラー発生時に処理を続行
            fso.CopyFile sourceFile, destinationFile, True ' 上書きコピー
            If Err.Number = 0 Then
                ' コピー成功時にC列とD列にフルパスを設定
                ws.Range("C" & i).Value = sourceFile
                ws.Range("D" & i).Value = destinationFile
            Else
                MsgBox "ファイルのコピーに失敗しました: " & sourceFile & " -> " & destinationFile & vbCrLf & Err.Description
            End If
            On Error GoTo 0 ' エラー処理をリセット
        Else
            MsgBox "ファイルが見つかりませんでした: " & ws.Range("B" & i).Value
        End If
        
        i = i + 1
    Loop
    
    ' コピー終了メッセージ
    MsgBox "ファイルのコピーが完了しました"
    
    ' オブジェクトの解放
    Set fso = Nothing
End Sub




Sub ClearFileEntries()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を適宜変更してください
    
    ' B7から下のセルをクリア
    ws.Range("B7:D" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row).ClearContents
End Sub