ファイル一括コピー

メインモジュール・コード

Option Explicit
Sub ファイル参照()

If MsgBox(ActiveCell.Address & "に設定しますか？", vbYesNo, "ファイルパス設定") = vbYes Then

    ActiveCell.Value = ファイル選択()

End If

End Sub
Sub フォルダ参照()

    Range("F2").Value = フォルダ選択() & "\"

    'ハイパーリンク設定
    ActiveSheet.Hyperlinks _
        .Add Anchor:=Range("F2"), Address:=Range("F2").Value

End Sub

Function ファイル選択()
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .AllowMultiSelect = False
        .Title = "ファイルの選択"
        If .Show = True Then
            ファイル選択 = .SelectedItems(1)
        Else
            MsgBox "選択されていません"
        End If
    End With
End Function
Sub ファイルコピー()

Dim tgtFolder As String
tgtFolder = Range("F2").Value

Dim rngList As Range
If Range("F5").Value <> "" Then
    Set rngList = Range(Range("F5"), Range("F5").End(xlDown))
Else
    MsgBox "コピーファイルが１つも設定されていません", vbCritical
    Exit Sub
End If

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

Dim myRng As Variant

On Error Resume Next
For Each myRng In rngList
    If myRng.Value <> "" Then
        FSO.CopyFile myRng, tgtFolder
    End If
Next myRng

Set FSO = Nothing

'エラー表示
Call エラー表示("コピー作成完了")
End Sub


Function フォルダ選択()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .AllowMultiSelect = False
        .Title = "フォルダの選択"
        If .Show = True Then
            フォルダ選択 = .SelectedItems(1)
        Else
            MsgBox "選択されていません"
            フォルダ選択 = ""
        End If
    End With
End Function

Sub エラー表示(Optional ByVal myMsg As String)

If Err.Number <> 0 Then
    MsgBox "エラー番号:" & Err.Number & vbCrLf & _
           "エラーの種類:" & Err.Description, vbExclamation
Else
    MsgBox myMsg
End If

End Sub

解説