VBAを使ってセル内に記述してある複数ファイル移動を移動

質問

VBAを用いたファイル移動に関して教えていただきたく
質問させていただきます。

VBAでファイルを移動する方法、*htmlなど特定の拡張子および、指定フォルダ内の全ファイル移動といった方法はわかりましたが、セル内に
記載してあるもののみ移動するだけがわかりませんでした。

やりたいこととしては
事前にjpgというフォルダから
読み込んでおいたjpgファイルのファイル名の一覧が
A列、B列、C列に記載されているのですが、それをマクロを実行するとtestというフォルダへ移動するようにしたいのです。

画像をすべて移動するだけなら、別にVBAを使わなくても
エクスプローラーで事足りてしまいますが、

画像ファイルがすべて数字で表記されていること
jpgファイル名一覧は原本で、実際には、原本のファイル名の一覧から数行だけをコピーして、別のシートを立ち上げ、そのシートに貼り付けられたjpgのファイル名だけを移動したいのです。

ここを参考にするといい！ですとか、あれば、併せて教えていただければ幸いです。よろしくお願いいたします。

回答No.3

nda23 · ベストアンサー

Const 移動元 As String = "C:\auctions\"
Const 移動先 As String = "C:\jpg\"
Dim FSO
Dim 最終行 As Long, 行 As Long, 列 As Long
Dim ファイル名 As String, 旧パス名 As String, 新パス名 As String
'== オブジェクトのインスタンス化
Set FSO = CreateObject("Scripting.FileSystemObject")
'== 最終行位置を求める
最終行 = Cells(65535, 1).End(xlUp).Row
行 = Cells(65535, 2).End(xlUp).Row
If 行 > 最終行 Then 最終行 = 行
行 = Cells(65535, 3).End(xlUp).Row
If 行 > 最終行 Then 最終行 = 行
'== エラーハンドリング開始
On Error Resume Next
'== 行のループ
For 行 = 1 To 最終行
　　'== 列のループ
　　For 列 = 1 To 3
　　　　ファイル名 = Cells(行, 列).Value
　　　　If ファイル名 <> "" Then '★空欄でなければ処理する
　　　　　　旧パス名 = 移動元 & ファイル名
　　　　　　'== 存在確認
　　　　　　FSO.GetFile 旧パス名
　　　　　　If Err.Number = vbNormal Then '★正常時のみ処理する
　　　　　　　　新パス名 = 移動先 & ファイル名
　　　　　　　　FSO.MoveFile 旧パス名, 新パス名
　　　　　　End If
　　　　　　'== エラーをリセットする
　　　　　　Err.Clear
　　　　End If
　　Next
Next
'== エラーハンドリング終了
On Error GoTo 0

Setはオブジェクト型の変数へ代入する場合に使用します。行位置などは
プリミティブな整数型なので、Setは使用しません。

お礼

返信が遅くなってしまい申し訳ありません。
まさに希望するとおりの動作をしてくれました。
正直記載していただいた内容は今の自分では
理解できない部分も多々ありましたが、
ご提示いただいた内容を自分の中で、今後
消化して、勉強していきたいと思います。

丁寧かつ迅速、的確な回答ありがとうございました。

回答No.4

imogasi

１．あるフォルダ内のファイルを全て捕まえ尽くすコードはわかった。
２．拡張子で判別して、望みの物以外を捨てる方法もわかった。
３．それならファイルを１つ捉えた段階で、エクセルの指定シートのセル範囲に、そのファイル名があるか見に行く（総あたり比較でよいではないの）
４．あった場合はＦＳＯのMoveFile (から）,(へ）を使って異動すればよい。
ーー
３．４で判らないことがあるのですか。
＞jpgファイル名一覧は原本で、実際には、原本のファイル名の一覧から数行だけをコピーして、別のシートを立ち上げ、そのシートに貼り付けられたjpgのファイル名だけを移動したいのです。
「張り付けられた」シートのセル範囲をファイル名を探す対象にすればよいのでは。なぜそれまでの前半文章説明（コピーしてとか立ち上げとかの説明）が必要ですか。

補足

回答ありがとうございます。
>「張り付けられた」シートのセル範囲をファイル名を探す対象にすればよいのでは。なぜそれまでの前半文章説明（コピーしてとか立ち上げとかの説明）が必要ですか。

たしかにおっしゃるとおりです。
後で読み返してみると、必要のない箇所が多々ありましたね。
今後はもっとわかりやすく簡潔に要点を伝えられるよう、
改善していきたいと思います。

ご指摘ありがとうございました。

回答No.2

nda23

参考です。
(1)各列の最終行の求め方
A列: Cells(65535, 1).End(xlUp).Row
B列: Cells(65535, 2).End(xlUp).Row
C列: Cells(65535, 3).End(xlUp).Row
(2)セル内容の取得とパス名の形成
Dim 旧パス名 As String
Dim 新パス名 As String
旧パス名 = "C:\jpg\" & Cells(行, 列).Value
新パス名 = "C:\test\" & Cells(行, 列).Value
(3)ファイルの移動方法
http://msdn.microsoft.com/ja-jp/library/cc428039.aspx
(4)エラーハンドリング
・旧ファイルがない場合
・新ファイルが既に存在する場合

補足

Sub Movejpg()

Dim A_End, B_End, C_End
Set A_End = Cells(65535, 1).End(xlUp).Row
Set B_End = Cells(65535, 2).End(xlUp).Row
Set C_End = Cells(65535, 3).End(xlUp).Row

Dim auctions As String
Dim jpg As String

auctions = "C:\auctions\" & Cells(A_End, 1).Value
jpg = "C:\jpg\" & Cells(A_End, 1).Value

Dim objFS
Set objFS = CreateObject("Scripting.FileSystemObject")
objFS.MoveFile auctions, jpg

End Sub
エラー処理はまだですが
上記のように組んでみました。
エラーが出てしまいました。
最初の最終行の求め方の部分で
実行時エラー 13
型が一致しませんとでてしまいました。
現在対処法を調べている最中ですが
時間がかかりそうなので、取り急ぎ報告させていただきました。
ご指摘いただければ幸いです。

回答No.1

nda23

疑問点は何でしょう？
(1)セルからファイル名を得る方法
(2)ファイル名が全て数字かを調べる方法
(3)シートの作成方法
(4)シートへのコピー
(5)ファイルの移動方法

補足

早速のご連絡ありがとうございます。
疑問点はセルに入力した値をもとにした複数ファイルの移動方法です。

たとえば
A1 に1.jpg
A2 に2.jpg
A3 に3.jpg
B1 に4.jpg
B2 に5.jpg
C1 に6.jpg
C2 に7.jpg

という風に入力してあった場合に
事前に指定しておいたjpgというフォルダ内の
1.jpg 2.jpg 3.jpg 4.jpg 5.jpg 6.jpg 7.jpgというファイルを
testというフォルダに移動したいのです。

他にも説明不足な点がございましたら、ご指摘いただければ幸いです。