エクセルVBAでセルにあるファイル名のファイルを同じくセルにあるフォルダ名のフォルダにコピー

質問

お世話になります。
絶対パスがあり、コピー元、コピー先(格納先)としてシート上の操作で
ファイルをフォルダにコピーしたいのですが、VBAでできるでしょうか？

・B列B6以下にコピー元のファイル名(絶対パス)
・D6に格納先のフォルダ名(絶対パス)
があります。
この条件だけでコピー→格納するコードを教えていただけたら助かります。よろしくお願いします。

回答No.3

misatoanna · ベストアンサー

またまた＃１です。　(^o^)丿

同名ファイルがあるときは　xxxx_01.jpg　の形式の連番を付加して別名で保存する
のを考えてみました。(連番は Max10 まで)

ファイル名とコピー先のフォルダパス名にアンダースコア（ _ ）が付いていない
ことが条件です。

Sub Test2()
　Dim i, OldFile, OldName, FileExt, NewFile, NewName, n, Pos
　i = 6
　Do While Cells(i, 2) <> ""
　　On Error Resume Next
　　MkDir Cells(6, 4).Value 　'コピー先に指定したフォルダがない場合は作成。
　　OldFile = Cells(i, 2)
　　OldName = Right(OldFile, Len(OldFile) - InStrRev(Cells(i, 2), "\") + 1)
　　OldName = Left(OldName, InStrRev(OldName, ".") - 1)
　　FileExt = Right(Cells(i, 2), Len(Cells(i, 2)) - InStrRev(Cells(i, 2), ".") + 1)
　　NewFile = Cells(6, 4) & OldName & FileExt
　　NewName = Left(NewFile, InStrRev(NewFile, ".") - 1)
　　If Dir(NewFile) <> "" Then
　　　For n = 1 To 10
　　　　Pos = InStrRev(NewName, "_")
　　　　If Pos = 0 Then Pos = Len(NewName)
　　　　NewFile = Left(NewName, Pos) & "_" & Format(n, "00") & FileExt
　　　　If Dir(NewFile) = "" Then Exit For
　　　Next
　　End If
　　FileCopy OldFile, NewFile
　　'Kill OldFile
　　i = i + 1
　Loop
End Sub

回答No.2

misatoanna

＃１です。

FileCopyを使った場合は、常に上書きになります。

同名ファイルがあった場合、コピー先の既存ファイルに連番をつける
ことは、私にはむずかしかったものですから‥‥。　(^^ゞ

なお、On Error Resume Next は、Ｂ列セルに記述されたファイルが
なかった場合に、無視して次の行を処理させるためにつけました。

回答No.1

misatoanna

稚拙ですが――

Sub Test()
　Dim i, OldFile, NewFile
　i = 6
　Do While Cells(i, 2) <> ""
　　On Error Resume Next
　　OldFile = Cells(i, 2).Value
　　NewFile = Cells(6, 4).Value & _
　　　　　　　　Right(OldFile, Len(OldFile) - InStrRev(OldFile, "\") + 1)
　　i = i + 1
　　FileCopy OldFile, NewFile
　　' Kill OldFile　　'元ファイルは削除したい場合はこの行を生かします。
　Loop
End Sub

お礼

misatoannaさんありがとうございました。ばっちりでした。
ひとつ質問させていただきたいのですが、

フォルダにファイルをコピーして格納します。
再度同じパスをコピーして格納すると、予想では「すでに同じ名前のファイルがあります・・・」というような表示が現れると思ったのですが、再度同じファイルをフォルダに入れてもそのような表示がありませんでした。On Error Resume Nextかな？と思ってコメントアウトした
のですが、それは関係ないようでした。こうゆうものでしたでしょうか？