VBAで、ファイルを移動する方法を教えてください。

質問

こんにちは。VBAの記述について質問させてください。

VBAのレベルは、簡単なマクロ処理(コピー、貼り付けしたり、シートの追加、削除をしたりできる程度です）を
VBAで書けるくらいの初心者です。

インターネットに掲載されている事例を見ながら一週間ほど試行錯誤しましたが、
どうしても、下層フォルダも含め、複数のファイルをまとめて移動する方法がわかりません。

いろいろ考えたところ、

1．下層フォルダも含め、ファイル名をまとめて取得

2．それをExcelに書き出してリストを作る

3．そのリストにあるものをすべてひとつのフォルダにまとめて移動する

という流れでやればいいのかな、と思いますが、
やり方がわかりません。

※そもそもこの考え方が違っていたら、ご指摘ください。

インターネットを参照すると、
まず、1、2は、次の方法でできることがわかりました。

参照サイト VBA応用
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_080.html
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Option Explicit

' 指定したフォルダ内のファイルの一覧を取得
Sub ファイル名一覧取得()
Const cnsTitle = "フォルダ内のファイル名一覧取得"
Const cnsDIR = "\*.*"
Dim xlAPP As Application
Dim strPATHNAME As String, vntPathName As Variant
Dim strFileName As String
Dim GYO As Long
Dim Shell, myPath

Set xlAPP = Application
' InputBoxでフォルダ指定を受ける
vntPathName = xlAPP.InputBox("参照するフォルダ名を入力して下さい。", _
cnsTitle, "C:\") ' (1)

strPATHNAME = vntPathName
' フォルダの存在確認
If Dir(strPATHNAME, vbDirectory) = "" Then
MsgBox "指定のフォルダは存在しません。", vbExclamation, cnsTitle
Exit Sub
End If

' 先頭のファイル名の取得
strFileName = Dir(strPATHNAME & cnsDIR, vbNormal)
' ファイルが見つからなくなるまで繰り返す
Do While strFileName <> ""
' 行を加算
GYO = GYO + 1 ' 先頭は1行目
Cells(GYO, 1).Value = strFileName
' 次のファイル名を取得
strFileName = Dir()
Loop

End Sub

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

これを行うと、A列にすべてのファイル名が書き出されます。

また、
動かしたいファイルが入っているフォルダと、ファイル名がわかっている場合は、
nameで動かせるのはわかりました。

例
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Name "C:\AAA\SAMPLE1.txt" As "C:\BBB\SAMPLE1.txt"

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

※こうすると、AAAというフォルダにあったSAMPLE1が、BBBに移動します。

この組み合わせで何とかできるのではないかと思うのですが、
ここから先が見えません。

実際に行いたい処理は、
図面がたくさん入っているフォルダが対象のフォルダになります。
※図面はzipファイルになっていますので、解凍をする必要があります。

ファイル名は、その時によって違うので、一旦

＝＝＝＝＝＝＝＝＝＝＝＝＝＝
C:\Users\Desktop\移動元
＝＝＝＝＝＝＝＝＝＝＝＝＝＝

というフォルダに格納します。

この中で、zipを解凍すると、
格納された複数のフォルダと2000個近くのファイルが出てきます。

ファイルの拡張子は特殊なものですが、ファイルを取り出すときに、
zip以外を取り出したいので、仮に、.xls .docとしておきます。

フォルダの名前やファイルの名前は図面の名称になっていますが、
今回は、

デスクトップ上の「移動先」というフォルダにすべてそのまま移動できればいいです。
＝＝＝＝＝＝＝＝＝＝＝
C:\Users\Desktop\移動先
＝＝＝＝＝＝＝＝＝＝＝
です。

実験用に、

デスクトップに、移動元というフォルダを作り、
その中に、子A、子B、子Cというフォルダを作り、
さらに、それぞれ、孫A、孫B、孫Cというフォルダを作りました。
それぞれの孫フォルダには、4つずつダミーファイルを入れました。

※これが、解凍後の状態になります。

図面の拡張子は特殊なものなので、今回は、わかりやすいように、
xlsとdocにします。

A-A-1.doc、A-A-1.xls、A-A-2.doc、A-A-2.xls

という感じです。

ファイル名は、A-A-1や、C-B-2のようにして、
それぞれ、
「子Aのフォルダの中の孫Aの1つ目」
「子Cのフォルダの中の孫Bの2つ目」

という意味になるようにしています。

書き出したリストと、
pathの組み合わせと、
For Nextもしくは
Do Loopの組み合わせで

なんとかなりそうなのですが、
頭の中が混乱して答えが導き出せません。

今週中に作らないといけないので、
お力をお貸しください。

よろしくお願いいたします。

回答No.3

nicotinism · ベストアンサー

では、
C:\Users\Desktop\移動元 という空っぽのフォルダがあったとして
ここにZipファイルを解凍した。
サブフォルダが幾つかとそれぞれのフォルダに複数のファイルが出来た。
Zipファイルを除きすべてのファイルをC:\Users\Desktop\移動先フォルダのルートに
移動したい。
という解釈であっているとして・・。

Sub test02()
　　Dim oFs As Object
　　Dim oDir As Object
　　Dim oFile As Object
　　Dim FromDir As String
　　Dim ToDir As String

　　FromDir = "C:\Users\Desktop\移動元"
　　ToDir = "C:\Users\Desktop\移動先\" '\を忘れずに

　　Set oFs = CreateObject("Scripting.FileSystemObject")
　　Set oDir = oFs.getfolder(FromDir)
　　Set oFile = oDir.Files

　　If oFs.FolderExists(FromDir) = False Then
　　　　MsgBox "送り元が見つかりません"
　　　　GoTo atoShimatu
　　End If

　　If oFs.FolderExists(ToDir) = False Then
　　　　If MsgBox("送り先フォルダが見つかりません。作成しますか？", vbYesNo) = vbNo Then
　　　　　　GoTo atoShimatu
　　　　Else
　　　　　　oFs.createFolder (ToDir)
　　　　End If
　　End If

　　If oFs.getfolder(ToDir).Size <> 0 Then
　　　　MsgBox ToDir & "にはファイルが残ってます。取りあえず中止。"
　　　　GoTo atoShimatu
　　End If

　　Call moveFiles(oDir.Path, ToDir)
　　Exit Sub

atoShimatu:
　　Set oFile = Nothing
　　Set oDir = Nothing
　　Set oFs = Nothing
End Sub

Private Sub moveFiles(oDirPath As String, toDirPath As String)
　　Dim oFs As Object
　　Dim oDir As Object
　　Dim oFile As Object
　　Dim FromDir As String
　　Dim ToDir As String

　　Set oFs = CreateObject("Scripting.FileSystemObject")
　　Set oDir = oFs.getfolder(oDirPath)
　　Set oFile = oDir.Files

　　For Each oFile In oDir.Files
　　　　If oFs.GetExtensionName(oFile) <> "zip" Then
　　　　　　'Debug.Print "FileName = ", oFile.Path, oFile.Name '確認用
　　　　　　'oFs.MoveFile oFile, ToDirPath '本番用(移動)？はこちら
　　　　　　oFs.CopyFile oFile, toDirPath, False '確認用、
　　　　　　'最後のFalseは既存ファイルがあればエラーになります
　　　　End If
　　Next

　　For Each oDir In oDir.SubFolders
　　　　'Debug.Print "folder = ", oDir.Name, oDir.Attributes ’確認用
　　　　Call moveFiles(oDir.Path, toDirPath)
　　Next

　　Set oFile = Nothing
　　Set oDir = Nothing
　　Set oFs = Nothing

End Sub

※Zipファイルを解凍してできたサブフォルダ内に同名のファイルがあった場合を考えると
oFs.CopyFile の方が安全かも？です。
絶対にありえない！確証があれば構いません。
（もし、存在した場合の処理は考えていません (^_^;) ）

test02 を実行してみてください。
moveFiles が実際の処理を行っています。
検証が不十分かと思いますので念入りに！

お礼

ありがとうございます！

すごいです。天才ですね。
一瞬でできました。

このままだと勉強にならないので、
まだ少し時間が残っているので、コードを解読できるようになってから上司に報告します。

本当にありがとうございました！

回答No.2

TAKA_R

そういえばこの間似た様なことをしたな、と思ったので。
ファイルを解凍する→これは守備範囲でないのですみませんが。先にやっておいてください。
ファイル名を書き出す。→これは成功したようですね。特定の拡張子のもののみを書き出すこともできます。多分見たサイトに載ってます。
移動させないファイルは削除する。
任意の場所に移動させる。
→→仮にＡ列に移動元ファイル名を並べます。Ｂ列に移動後のファイル名を書きます。
name range("a" & k) as range("b" & k)
これを for文（変数k）で行数分回せば、時間はかかりますが、できると思います。

お礼

ご回答ありがとうございました。

もう一人の方の方法で動かすことができました。

勉強のために教えていただいた方法でもやってみます。

回答No.1

nicotinism

Scripting オブジェクトのMoveFolderを使えばフォルダごとごっそりと移動できます。
sub test01
dim oFs as object
set oFs = CreateObject("scripting.filesystemObject")
oFs.moveFolder "C:\Users\Desktop\移動元" , "C:\Users\Desktop\移動先"
set oFs = nothing
end sub

※移動先フォルダが存在しない場合に自動的に作成移動されます。
既に移動先フォルダが存在し、フォルダ内にファイル・サブフォルダがある場合はエラーになります。
Zipファイルだけを除外するようなオプションはありません。

VBA標準のステートメントだけでは不自由なのでマスターしてください。
http://www.happy2-island.com/vbs/cafe02/capter00216.shtml

お礼

ありがとうございました。
補足に書いた通りなのですが、今回、フォルダは除きたいのです。

ちなみに、Windows7では、
フォルダの検索窓で、.xls OR .docと検索して、
全選択→切り取り→任意のフォルダに貼り付け
をすれば一発ですが、WindowsXPではこれができませんでした。

補足

説明が足らず申し訳ありません。
フォルダは除いて、ファイルのみ移動したいのです。

buf=dir()を使ってうまくできそうな気がしましたが、まだできていません。

ご回答お願いいたします。