ファイル名から該当フォルダへ移動

大量のファイル（.doc）をファイル名から該当フォルダへ移動させたいのですが、
VBAかbatで可能でしょうか？

【ファイル名】
・○名前○_20170801.doc　→　○名前○フォルダへ
・△名前△_201708009.doc　→　△名前△フォルダへ
・□名前□_20170726.doc　→　□名前□フォルダへ
・△名前△_20170801.doc　→　△名前△フォルダへ

ファイルとフォルダは同じところにあります。

よろしくお願いします。

No.1 回答者： めぐみん_ 回答日時： 2017/08/11 05:04

bat はわからないですがＶＢＡなら可能ではないでしょうか？

ただわざわざ移動のためにＶＢＡ（Ｅｘｃｅｌなどを起動）でやるのもどうかと思いますけど。
Yahoo！知恵袋とかにはVBSをメインに回答されている方もいるようですので、そっちを使う方が楽かな？

あと移動した時にファイル名にはフォルダ名が残っていても良いのでしょうか。

No.2 ベストアンサー 回答者： tatsu99 回答日時： 2017/08/11 18:12

vbaでの実装例です。

以下のマクロを標準モジュールへ登録してください。
-------------------------------------------
Option Explicit
Public Sub ファイル移動()
Const Folder As String = "d:\goo\data\goo214" 'DOC格納フォルダ
Const FORCE_REPLACE As Boolean = True '同一ファイルが存在するときの強制上書き(true=上書きする、false=上書きしない）
Dim FSO As Object 'Filesystem
Dim dicT As Object '連想配列
Dim RE As Object '正規表現
Dim dirName As String
Dim fileName As String
Dim result As Object
Dim mstr As String
Dim oldname As String
Dim newname As String
Dim count As Long
Dim atr As Integer
Set FSO = CreateObject("Scripting.FileSystemObject")
Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set RE = CreateObject("VBScript.RegExp")
RE.Pattern = "^.*名前.*_"
RE.Global = True

dirName = Dir(Folder & "\*名前*", vbDirectory)
If dirName = "" Then
MsgBox (Folder & "内にフォルダが存在しません。")
Exit Sub
End If
'全てのフォルダを処理する
Do While dirName <> ""
'フォルダ名の記憶
If (GetAttr(Folder & "\" & dirName) And vbDirectory) <> 0 Then
dicT(dirName) = True
End If
dirName = Dir()
Loop
fileName = Dir(Folder & "\*名前*.doc", vbNormal)
If fileName = "" Then
MsgBox (Folder & "内にDOCが存在しません。")
Exit Sub
End If
'全てのファイルを処理する
count = 0
Do While fileName <> ""
Set result = RE.Execute(fileName)
If result.count > 0 Then
mstr = result(0).Value
mstr = Left(mstr, Len(mstr) - 1)
If dicT.exists(mstr) = True Then
oldname = Folder & "\" & fileName
newname = Folder & "\" & mstr & "\" & fileName
MsgBox ("<" & oldname & "><" & newname & ">") '移動前後のファイル名表示
If FSO.FileExists(newname) Then '移動先にファイルが存在するなら
If FORCE_REPLACE = True Then '同一ファイル存在時の上書き指定がtrueなら
FSO.deletefile newname '元のファイルを削除して
FSO.movefile oldname, newname '移動先に移動する
count = count + 1 '移動件数アップ
End If
Else '移動先にファイルが存在しないなら
FSO.movefile oldname, newname '移動先に移動する
count = count + 1 '移動件数アップ
End If
End If
End If
fileName = Dir()
Loop
MsgBox (count & "件のファイルを移動しました")
End Sub
-----------------------------------------------
使用時の注意
Const Folder As String = "d:\goo\data\goo214" 'DOC格納フォルダ
docが存在するフォルダです。あなたの環境にあわせて適切に設定してください。

Const FORCE_REPLACE As Boolean = True '同一ファイルが存在するときの強制上書き(true=上書きする、false=上書きしない）
同一ファイルが移動先に存在する場合の扱いです。
現在は、trueなので、強制的に移動（上書き）します。
これをflaseにすると移動しません。

この回答へのお礼

実装例ありがとうございます。
説明が足らなかったようでごめんなさい。
名前のところは、処理した人の名前が入ります。
山田とか佐藤とか。。。
このあたりでどのように処理したらよいのか。。。

お礼日時：2017/08/14 08:16

No.3 回答者： tatsu99 回答日時： 2017/08/14 09:20

>名前のところは、処理した人の名前が入ります。

>山田とか佐藤とか。。。

そうなると、マクロでは、名前のところは、任意の文字として扱うので、
○△□●▲■_20170801.doc →　○△□●▲■フォルダへ　
●○●_20170726.doc →　●○●フォルダへ
○△□_20170802.doc →　○△□フォルダへ　
のような移動になります。

誤動作させない為には、以下の条件が必要です。
１）日付の部分(20170802等)は、必ず、8桁でしょうか。
２）日付の前の_（アンダーバー）は、必ず、半角のアンダーバーで、
　 ○名前○の中にアンダーバーが含まれることはないと考えて良いですか。
つまり
△佐藤△＿20170801.doc　（全角のアンダーバー）
△_佐藤△_20170801.doc (アンダーバーが２つある)
上記のようなケースはないと考えて良いですか。

この回答へのお礼

実際のファイル名はもう少し複雑になってしまいます。
*****(数字5桁)_場所_ファイル名_処理した人の名前.doc
処理した人の名前フォルダがあるので、ファイル名にある名前部分と同様のフォルダへ振り分けたいと思っています。
（名前の重複はありません。）

お礼日時：2017/08/14 10:09

No.4 回答者： tatsu99 回答日時： 2017/08/14 10:28

すみません。

ますます、わからなくなってきました。
>実際のファイル名はもう少し複雑になってしまいます。
>*****(数字5桁)_場所_ファイル名_処理した人の名前.doc
>処理した人の名前フォルダがあるので、ファイル名にある名前部分と同様のフォルダへ振り分けたいと思っています。

１）最初に提示された日付の部分（20170801等）はどこなのでしょうか。
２）「ファイル名」のなかに名前の部分があって、「処理した人の名前」にも名前があるのですか。

具体的な、以下について実際の例を提示していただけませんでしょうか。
①実際のファイル名
②移動したいフォルダ名

この回答へのお礼

すみません、実際のファイル名は仕事の内容が分かってしまう為、控えております。
やりたい事は、ファイル名に処理した人の名前が入っているので、同じ名前のフォルダへ移動したいのです。

お礼日時：2017/08/14 10:59

No.5 回答者： tatsu99 回答日時： 2017/08/14 11:07

>やりたい事は、ファイル名に処理した人の名前が入っているので、同じ名前のフォルダへ移動したいのです。

そのフォルダ名があなたから提示された仕様では特定できないのです。
（フォルダ名の特定ができれば何とか、なりますが・・・・・）

本件、私のスキルでは解決できませんので、申し訳ありませんが、離脱いたします。
他の回答者からの適切な回答を待っていただけますでしょうか。

この回答へのお礼

いろいろとありがとうございます。
batでやってみようかと思います。

お礼日時：2017/08/14 16:41