エクセルで電子納品を楽にする

ソフトを使わずに電子納品のファイルを用意するのはなかなか手間がかかるので、
最終的なファイルを集める作業とかファイル名称を変えつつコピーする部分をエクセルで集計してやる方法を思いついた。

そのほかにも使えるケースがあるかもしれないので、
アップしてみる。

ファイル収集(電子納品などにどうぞ)
ちなみに、黄色い背景にしている範囲をダブルクリックすると、そのセル以下に選んだファイルパスが登録できます。

マクロ部分。(雑ですみません)

‘—————————————————————
‘2015/3/29
‘作成環境: Excel2010
‘
‘known bugs: まだ解らない. 😉
‘
‘—————————————————————

Private Sub StartFileCopy()
On Error GoTo ErrorHandler

Set fs = CreateObject(“Scripting.FileSystemObject”)
Dim gyo As Integer
Dim targetDir As String

If Range(“B” & CStr(7)).Value = “” Then
MsgBox “ファイル登録が一つも無い…”, , “ちょっとまって！”
Exit Sub
End If

targetDir = Range(“C3”).Value

Do
If Range(“B” & CStr(gyo + 7)).Value = “” Then Exit Do ‘指定ファイルが書いてないとき

‘登録したPATH
‘MsgBox Range(“B” & CStr(gyo + 7)).Value
‘フォルダー名取得
‘MsgBox fs.GetParentFolderName(Range(“B” & CStr(gyo + 7)).Value)
‘ファイル名取得
‘MsgBox fs.GetFileName(Range(“B” & CStr(gyo + 7)).Value)
‘拡張子取得
‘MsgBox fs.GetExtensionName(Range(“B” & CStr(gyo + 7)).Value)

If Range(“c” & CStr(gyo + 7)).Value = “” Then
‘リネーム名指定なしの場合はファイル名そのままでコピー
fs.CopyFile Range(“B” & CStr(gyo + 7)).Value, _
targetDir & “\” & fs.GetFileName(Range(“B” & CStr(gyo + 7)).Value), False
Else
‘リネーム名指の指定があれば、コピー
fs.CopyFile Range(“B” & CStr(gyo + 7)).Value, _
targetDir & “\” & Range(“c” & CStr(gyo + 7)).Value & “.” & fs.GetExtensionName(Range(“B” & CStr(gyo + 7)).Value), _
False
End If

gyo = gyo + 1

Loop Until gyo > 999 ‘1000超えたら

Set fs = Nothing

Exit Sub

ErrorHandler:
Close
MsgBox “エラーです”, 0, “困ったことに”
Set fs = Nothing
Exit Sub

End Sub

Private Sub Button1_Click()
Call StartFileCopy

End Sub

Private Sub SetFilePath(ByVal StartTarget As Range)
Set fs = CreateObject(“Scripting.FileSystemObject”)

flist = Application.GetOpenFilename( _
FileFilter:=”すべてのファイル,*.*, エクセルファイル,*.xlsx, ワードファイル,*.docx”, _
FilterIndex:=1, _
MultiSelect:=True _
)

If IsArray(flist) Then
For i = 1 To UBound(flist)
Range(“B” & CStr(StartTarget.Cells.Row + i – 1)).Value = flist(i)
Next
End If

Set fs = Nothing

End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

‘ダブルクリックした位置よりファイルパスを登録処理
If Target.Cells.Column = 2 And Target.Cells.Row >= 7 Then
Cancel = True
Call SetFilePath(Target)
End If

End Sub