ファイルの整理 バッチファイルの作成_2

質問

フォルダ内にある
複数のフォルダ内に点在する
5000個のファイルのうち

エクセルに書かれた1000項目のファイルを取り出し違うフォルダに移したいのですが
現在一つ一つ手作業で、移動させています。

フォルダ構成を守りながら

さくっと移動作業が終わらせれる
コマンドプロントや、バッチファイルあるいはそういうことができるツールなどあれば
ご教授お願いできないでしょうか？

作業としては、単純なのですが、１日つぶしてしまい、時間をもったいなく感じております。

よろしくお願い致します

回答No.4

NotFound404 · ベストアンサー

最初の回答のあらましを言うと
C:\Data\org フォルダがあったとして
マクロを実行すると
A列の選択セルが一つずつ下にずれて行きます。
セル中のファイル名が上記フォルダに無い場合にはNotFound
他にエラーが発生した場合はErrorエラーメッセージが
右隣のセルに入ります。
『おしまい』と出たらOKをおしてフォルダを見ると
C:\Date\org_New フォルダに欲しいものが入っているハズ。

使い方
Sub main() から一番下までコピー
あなたのリストが入っているエクセルファイルを開きます。
Alt + F11 でVBEの画面が開きます。
Alt + I でプルダウンから、標準モジュールを選択
カーソルが点滅している新たなウィンドウが開くので
Ctrl + V で貼り付け
Alt + D でプルダウンから、VBAプロジェクトのコンパイルを選択
何も起こらなかったら、うまく行っているので
Alt + F4 でVBE を閉じます。
通常のExcel画面に戻るので
Alt + F8 でマクロの選択画面がでるので実行します。
そうすると最初のような動作を行います。

で質問の部分ですが（C:\Data\org フォルダがあったとして）なら
Const TrgDir As String = "e:\tmp" '←★★ここを元のフォルダ名に
↓
Const TrgDir As String = "C:\Data\org" '←★★ここを元のフォルダ名に
になります。

なお、マクロ処理を途中で止めたいときには、Ctrl + Break で現れる画面の
「デバッグ」というボタンを押し、 Alt + R でプルダウンから リセット を選択
Alt + F4 で VBE を閉じます。

※途中で止めた場合や再実行したい場合は出来ているC:\Date\org_New フォルダを
削除してからでないとエラーになります。
ファイルを保存するときは、XLS か XLSM 形式で行ってください。
Excel VBA のサイトは数多くあるのでのぞいてみてください。
たとえば
http://excelvba.pc-users.net/index.html
など。

お礼

恐れ入ります。

返答遅くなってしまい申し訳ありません。

NotFound404 さんに教えていただいた

プログラムについて、今度一度試してみようと思います。

ご丁寧にご回答頂きありがとう御座いました。

回答No.3

NotFound404

コマンドプロンプトのXCopyやRoboCopyでフォルダ構造ごとコピーできるのですが
問題は、A列のリストだけをコピーする部分で
上記コマンドでも除外リストのオプションはありますが
その反対のリストだけをコピーというのはありません。
なのでVBAで長いコードになってしまった訳です。
BATファイルで可能かどうかは不明のため分かりません。

お礼

なるほど、リストに書かれているものだけコピーというのがネックなのですね。

以前ご回答いただいた部分で質問なのですが

Const TrgDir As String = "e:\tmp" '←★★ここを元のフォルダ名に

この部分について

e:\tmp　に元フォルダ名を入れるのか

" '　の間に入れるのか

←★★　の星の部分に入れるのか少し理解しかねる状態です。

後

Excelの標準モジュールで（main）マクロ

とは何のことでしょう？

初心者過ぎてすみません。

回答No.2

NotFound404

極力早い処理をと思いつつもこの辺が私の限界です。
★★の所はそちらの環境に応じて変更要
Excelの標準モジュールで（main）マクロをお試しを。多分20分～一時間程度掛かります。
汚いコードですみません。
投稿用にTABインデントを全角スペースに変換しています
エラーが発生した場合は
エラーになった行とエラーメッセージをお知らせください。

Sub main()
On Error GoTo errH
Const TrgDir As String = "e:\tmp" '←★★ここを元のフォルダ名に
　　Dim newDir As String
　　Dim ofs As Object
　　Dim c As Range
　　newDir = TrgDir & "_New"

　　Set ofs = CreateObject("Scripting.FileSystemObject")
　　newDir = TrgDir & "_New"

　　If ofs.folderexists(TrgDir & "_New") = False Then
　　　　ofs.CreateFolder TrgDir & "_New"
　　End If

　　Call makeDir(TrgDir, TrgDir, newDir)

Dim FileDics As Object, Pathdics As Object
Dim FileKey As Variant, PathKey As Variant
　　Set FileDics = CreateObject("Scripting.Dictionary")

　　Set Pathdics = CreateObject("Scripting.Dictionary")
　　Call makePathdics(Pathdics, TrgDir)
　　For Each PathKey In Pathdics.Keys
　　　Debug.Print PathKey, Pathdics.Item(PathKey)
　　Next

Dim Found As Boolean
Dim j As Long
Dim cv As String

　　For Each c In Sheets("sheet1").Range("A1", Range("A1").End(xlDown))
　　　c.Select
　　　cv = c.Value
　　　Found = False
　　　　For Each PathKey In Pathdics.Keys
　　　　　　j = j + 1
　　　　　　DoEvents
　　　　　　Debug.Print c.Row, j
　　　　　　If cv = Pathdics.Item(PathKey) Then
　　　　　　　　ofs.copyfile PathKey, Replace(PathKey, TrgDir, newDir, compare:=vbTextCompare)
　　　　　　　　Found = True
　　　　　　End If
　　　　Next PathKey
　　　　If Found = False Then
　　　　　c.Offset(0, 1).Value = "NotFound"
　　　　End If
　　Next c

Call delDir(newDir)

　　Set ofs = Nothing
beep:　　beep
MsgBox "おしまい"
Exit Sub
errH:
　　　　　c.Offset(0, 1).Value = "Error" & Err.Description
　　　　　Resume Next
End Sub

Private Sub makeDir(TrgDir As String, BaseDir As String, newDir As String)
　　Dim ofs As Object
　　Dim objDir As Object

　　Set ofs = CreateObject("Scripting.FileSystemObject")
　　Set objDir = ofs.getfolder(TrgDir)

　　For Each objDir In objDir.SubFolders
　　　　Debug.Print objDir.Path, TrgDir, newDir
　　　　ofs.CreateFolder Replace(objDir.Path, BaseDir, newDir, compare:=vbTextCompare)
　　　　Call makeDir(objDir.Path, BaseDir, newDir)
　　Next

　　Set objDir = Nothing: Set ofs = Nothing
End Sub

Private Sub delDir(ByVal newDir As String)
'空のフォルダの削除
　　Dim ofs As Object
　　Dim objDirSub As Object, objDir As Object
　　Set ofs = CreateObject("Scripting.FileSystemObject")
　　Set objDir = ofs.getfolder(newDir)

　　For Each objDirSub In objDir.SubFolders
　　　　Debug.Print objDirSub.Path
　　　　Call delDir(objDirSub.Path)
　　Next

　　If objDir.Files.Count = 0 And objDir.SubFolders.Count = 0 Then
　　　　ofs.deletefolder objDir
　　End If
End Sub

Private Function makePathdics(ByRef Pathdics As Object, ByVal TergetFolder As String)
　　Dim oFile　 As Object
　　Dim oFolder　As Object
　　Dim oFolders As Object
　　Dim ofs　　 As Object

　　Set ofs = CreateObject("Scripting.FileSystemObject")

　　For Each oFile In ofs.getfolder(TergetFolder).Files
　　　　Pathdics.Add oFile, oFile.Name
　　Next

　　Set oFolders = ofs.getfolder(TergetFolder)
　　For Each oFolder In oFolders.SubFolders
　　　　Call makePathdics(Pathdics, oFolder.Path)
　　Next

End Function

お礼

すみません、すごく長く丁寧にプログラミングを書いていただき
ありがとう御座います。

自分はプログラミングの知識はほぼ皆無に等しいので

自分が過去に質問した、

『ファイルの整理　バッチファイルの作成』

みたいな感じで、初心者にも優しい感じで

作るのは、やることが複雑すぎて不可能でしょうか？

回答No.1

NotFound404

解決に至る前段階ですが
セルにはどのように入っているのでしょう？
例えばファイル名だけが
abc.txt
aad.txt
・・・
と入っていて
複数のフォルダに
いろはフォルダにも、あいうフォルダにもabc.txt というファイルがあった場合は
両方とも移動したいのですよね？
か、セルにはフルパスで入っているのか。

また、複数のフォルダが
あるフォルダを起点としてサブフォルダにまとまっているのか
または、
c:\users\myName\documents\
d:\data\
・・・
などと、とっちらかっているのか？

という状況説明が無いと具体的な回答は難しいかと思いますよ。

お礼

セルには、A列に

aaa.txt
ccc.txt
ggg.txt
hhh.txt
kkk.txt

とファイル名だけ書かれている状態で

フォルダ構成の例としては

mainフォルダ
│
├aフォルダ
│ └ aaa.txt
│
├bフォルダ
│ └ bbb.txt
│
├cフォルダ
│ ├eフォルダ
│ │ └aaa.txt
│ │
│ └ccc.txt
│
└dフォルダ
├eee.txt
│
└ddd.txt

といった感じでフォルダ構成は、ランダムで
名前がかぶっているのもあり

そのままフォルダ構成をいじしたまま
エクセルにピックアップされているファイルを
違うmainフォルダ移動またはコピーしたいと思っています。

この質問の仕方で、情報量としては足りますでしょうか？