あるフォルダーのファイルを違う親フォルダーのサブフォルダーに移したい

Question

タイトルに書きました通り、特定のフォルダーのファイルを違う親フォルダーのサブフォルダーに移動したいのですが、移動先がたくさんのフォルダーが階層になっていて上手く処理できません。

ファイル名と一致するサブフォルダーに移動したいのですが、このファイル名も半角スペースがたくさん入っていて冗長になっています。

自分で色々調べて書いてみたのですが、再起処理が上手くできません。

どうかお力をお貸しいただけませんか？

Sub Test()
Dim MyPath As String
MyPath = "C:\Users\owner\Desktop\A\B\"
Call Sample(MyPath)
End Sub

Sub Sample(MyPath As String)
Dim F As Object

        Const folder1 As String = "C:\Users\owner\Desktop\テスト用\"
        Dim ファイル名, フォルダ名1, フォルダ名2, フォルダ名3 As String


        ファイル名 = Dir(folder1 & "*記録用*.xls")
        Do Until ファイル名 = ""

            フォルダ名1 = Split(ファイル名, " 記録用")(0)
            フォルダ名2 = Mid(フォルダ名1, InStr(フォルダ名1, " ") + 1)
            フォルダ名3 = Mid(フォルダ名2, InStr(フォルダ名2, " ") + 1)

            If Dir(MyPath & フォルダ名3, vbDirectory) <> "" Then


            Name folder1 & ファイル名 As MyPath & フォルダ名2

            End If

            ファイル名 = Dir()

        Loop


With CreateObject("Scripting.FileSystemObject")
        For Each F In .GetFolder(MyPath).SubFolders
            Call Sample(F.Path)
        Next F
    End With
End Sub

tatsumaru77 · Accepted Answer

下記URLにアップしました。
標準モジュールに登録してください。
https://ideone.com/2oDCwZ

使用時の注意事項
１．シート：移動結果　を作成してから、マクロを実行してください。
シート：移動結果の1行目（見出し）は、あなたが作成してください。
マクロは２行目以降から書き込みを行います。

２．C,E列の表示のハイパーリンクを通常表示に変える場合は、
Const Hyper_Link As Boolean = True　を
Const Hyper_Link As Boolean = False にしてください。

その他、不明点があれば補足してください。

tatsumaru77 · Answer

No9です。
アップした画像が不鮮明なので、こちらにアップしました。
こちらを参照ください。
https://gyazo.com/0bd339bb5dd086e92152bd17a351376d

tatsumaru77 · Answer

No8です。補足ありがとうございました。
ほかの方が既に、回答され解決されているので、回答をやめようかと思いましたが、
質問者の方が丁寧に補足されているので回答しました。

ファイルの移動を行った時の結果を、シート：「移動結果」に表示しようと思いますがいかがでしょうか。
①E列にC:\Users\owner\Desktop\A\B　下のサブフォルダの一覧が表示されます。

②A列にC:\Users\owner\Desktop\テスト用　下のファイルの一覧が表示されます。

③B列に移動結果の状態が表示されます。
完了・・・移動が完了したファイル
ERR1・・・移動対象外のファイル（日付＋空白＋通し番号＋空白＋任意の文字＋空白＋記録用.xlsx の形式になっていないファイル）
ERR2・・・移動対象となるフォルダが存在しなかった為、移動されなかったファイル
添付図の例では● ●のフォルダがないため、移動されなかったケースになるます。
ERR3・・・移動対象となったが、移動先のフォルダに既に同名のファイルが存在するため、移動しなかったファイル

④C列の移動先のフォルダが表示されます。（状態が完了、ERR3の場合のみ表示）

E列及びC列のフォルダ名は、こちらの環境ではD:\goo\data8\aaa2の環境で試験しているため、
C:\Users\owner\Desktop\A\B\○○のようには表示されていません。

E列及びC列のフォルダ名は、ハイパーリンク形式で表示しています。
このセルをクリックすると直接そのフォルダをエクスプローラで表示することができます。
（ハイパーリンクによる表示をやめたい場合は、マクロ中の設定を変えれば通常の表示に切り替わります）

マクロを実行する場合は、事前にシート：「移動結果」を用意しておく必要があります。

tatsumaru77 · Answer

No6です。確認事項の追加です。
１．ファイル名が以下のようなケースは移動対象外で良いですか。
（半角１桁の空白を□で表しています）
①　200303□5678□☆●●記録用.xlsx　・・・「記録用」の前に空白がない

２．複数のフォルダが移動対象の候補として存在する時、どのフォルダに移動されるかは
　不確定ですがよろしいでしょうか。（マクロが最初に検知したほうのフォルダになります）
例
C:\Users\owner\Desktop\A\B\xxx\yyy\ABC〇〇△△
C:\Users\owner\Desktop\A\B\abc\yyy\ABC〇〇△△
の２つのフォルダがあったとき
200303□5678□〇〇△△□記録用.xlsx
（半角１桁の空白を□で表しています）
のファイルは、どちらのフォルダに移動されるかは不確定です。
（マクロが最初に検知したほうのフォルダに移動されます）

３．移動先のフォルダに移動対象となるファイルが既に存在する場合は、
移動を行いませんがよろしいでしょうか。

Qchan1962 · Answer

＃５です自身で指摘した問題を書いてしまいました最初のサブフォルダアドレスの配列を作り　最下層のフォルダ名と変数フォルダー名3が一致したフォルダに名前を変更し対象ファイルを移動 *記録用*.xlsx が無くなるまで繰り返す　　ロジックに変更しました＃５同様　デバッグは環境不明な点がある為　行っていません必要に応じて手を加えてください（振り分け条件不測の為、同名フォルダが複数存在する場合バグが発生します）フォルダリスト取得ロジックはコード内記載のサイトを参考にしました（適当な判断、想定で上手く動く可能性は低いですが　一応返信） Sub sample() Dim v As Variant v = GetFileList("C:\Users\owner\Desktop\A\B") Const folder1 As String = "C:\Users\owner\Desktop\テスト用\" Dim ファイル名, フォルダ名1, フォルダ名2, フォルダ名3 As String ファイル名 = Dir(folder1 & "*記録用*.xlsx") Do While ファイル名 <> "" フォルダ名1 = Split(ファイル名, " 記録用")(0) フォルダ名2 = Mid(フォルダ名1, InStr(フォルダ名1, " ") + 1) フォルダ名3 = Mid(フォルダ名2, InStr(フォルダ名2, " ") + 1) Dim tmp As Variant, i As Long For i = UBound(v) To 0 Step -1 tmp = Split(v(i), "\") If tmp(UBound(tmp)) = フォルダ名3 Then 'メイン処理 Name folder1 & ファイル名 As v(i) & "\" & フォルダ名2 & ".xlsx" Exit For End If Next ファイル名 = Dir() Loop End Sub 'https://excel-ubara.com/excelvba5/EXCELVBA233.html そのまま Function GetFileList(ByVal argDir As String) As String() Dim i As Long: i = 0 Dim aryDir() As String Dim strName As String ReDim aryDir(i) aryDir(i) = argDir Do strName = Dir(aryDir(i) & "\", vbDirectory) Do While strName <> "" If GetAttr(aryDir(i) & "\" & strName) And vbDirectory Then If strName <> "." And strName <> ".." Then ReDim Preserve aryDir(UBound(aryDir) + 1) aryDir(UBound(aryDir)) = aryDir(i) & "\" & strName End If End If strName = Dir() Loop i = i + 1 If i > UBound(aryDir) Then Exit Do Loop GetFileList = aryDir End Function

tatsumaru77 · Answer

No3です。
補足ありがとうございました。確認事項です。
１．拡張子は.xlsxである。
（拡張子が.xlsm .xls 等は移動対象外とする）
上記の条件で良いですか。

２．ファイル名について
①日付の年月日は６桁の数字である前提で良いですか。
（６桁以外の場合は移動対象外となります）

②通し番号は４桁固定でしょうか。それとも可変でしょうか。

③日付の後の半角スペースは１桁固定でしょうか。それとも２桁以上の場合もありますか。
例　200303□□5678□☆ ●●□記録用.xlsx
（半角１桁の空白を□で表しています）
のようなケースです。

④通し番号の後の半角スペースは１桁固定でしょうか。それとも２桁以上の場合もありますか。
例　200303□5678□□☆ ●●□記録用.xlsx
（半角１桁の空白を□で表しています）
のようなケースです。

⑤記録用文字の前の半角スペースは１桁固定でしょうか。それとも２桁以上の場合もありますか。
例　200303□5678□☆ ●●□□記録用.xlsx
（半角１桁の空白を□で表しています）
のようなケースです。

３．取得したフォルダ名３について
取得したフォルダ名３の中に半角スペースが含まれることはありますか。
例　200303□□5678□☆□●●□記録用.xlsx
（半角１桁の空白を□で表しています）
の場合、フォルダ名３は「☆□●●」になりますが、このようなケースはありますか。

４．サブフォルダについて
「"C:\Users\owner\Desktop\A\B\"のサブフォルダーのサブフォルダーのさらにサブフォルダーに記録用のファイルと部分一致するサブフォルダーがあり」
ということですが、３番目のサブフォルダーのみがチェックの対象となると理解して良いでしょうか。
"C:\Users\owner\Desktop\A\B\SUB1\SUB2\SUB3"のフォルダがあった場合（SUB1,SUB2,SUB3フォルダの文字は任意）
SUB3のフォルダのみが部分一致するかのチェック対象となる。
（SUB2のフォルダが部分一致しても、SUB3のフォルダが部分一致しなければ、移動対象外となる）

５．「部分一致する」について
以下の解釈であってますか。
取得したフォルダ名３が「〇〇△△」の場合、
サブフォルダ名＝ABC〇〇△△XYZ　・・・部分一致する
サブフォルダ名＝ABC〇〇△XYZ　・・・部分一致しない（△が１つ足りない）
サブフォルダ名＝ABC〇〇△△△XYZ　・・・部分一致する

取得したフォルダ名３が「〇〇□△△」の場合、
（半角１桁の空白を□で表しています）
サブフォルダ名＝ABC〇〇□△△XYZ　・・・部分一致する
サブフォルダ名＝ABC〇〇△△XYZ　・・・部分一致しない（□がない）
サブフォルダ名＝ABC〇〇□△△△XYZ　・・・部分一致する

６．念のための確認
ファイル名が以下のようなケースは移動対象外で良いですか。
（半角１桁の空白を□で表しています）
①　200303□5678□☆●●□記憶用.xlsx　・・・ファイル名の最後の３文字が「記録用」でない
②　200303□5678☆●●記録用.xlsx　・・・「通し番号」の後に空白がない
③　2003035678□☆●●記録用.xlsx　・・・「日付」の後に空白がない
④　□200303□5678□☆●●記録用.xlsx　・・・「日付」の前に空白ある

Qchan1962 · Answer

＃４一応　参考プロシージャフォルダ名1 = Split(ファイル名, " 記録用")(0) フォルダ名2 = Mid(フォルダ名1, InStr(フォルダ名1, " ") + 1) フォルダ名3 = Mid(フォルダ名2, InStr(フォルダ名2, " ") + 1) 上記が正しく取得できるものとした場合のサンプルです（拡張子付き）（手直しが必要と思われるので　ステップ実行などで各変数値を確認しながらデバッグしてください） Dim Target_path As String　'モジュールレベル変数で対応 Sub Test() Dim MyPath As String MyPath = "C:\Users\owner\Desktop\A\B\" '出力先親フォルダパス Const folder1 As String = "C:\Users\owner\Desktop\テスト用\" '元ファイルフォルダパス Dim ファイル名, フォルダ名1, フォルダ名2, フォルダ名3 As String ファイル名 = Dir(folder1 & "*記録用*.xls") Do While ファイル名 <> "" フォルダ名1 = Split(ファイル名, " 記録用")(0) フォルダ名2 = Mid(フォルダ名1, InStr(フォルダ名1, " ") + 1) フォルダ名3 = Mid(フォルダ名2, InStr(フォルダ名2, " ") + 1) Call find_subFolder(MyPath, フォルダ名3) 'フォルダ名3名のサブフォルダを探す If Target_path <> "" Then 'メイン処理（ファイルを別名で移動 Name folder1 & ファイル名 As Target_path & "\" & フォルダ名2 & ".xls" End If ファイル名 = Dir() Loop End Sub Sub find_subFolder(MyPath As String, フォルダ名3 As String) Dim fso As Object, s_fol As Object Dim fol As String Target_path = "" '初期化 fol = Dir(MyPath & "\", vbDirectory) '1個目のフォルダ名を格納 Do While fol <> "" 'folが空になるまでDo While内の処理を続ける If (GetAttr(MyPath & "\" & fol) And vbDirectory) = vbDirectory Then If fol <> "." And fol <> ".." Then If フォルダ名3 = fol Then Target_path = MyPath & "\" & fol 'パスを取得設定 Exit Sub End If End If End If fol = Dir() '次のフォルダ名 Loop Set fso = CreateObject("Scripting.FileSystemObject") For Each s_fol In fso.GetFolder(MyPath).SubFolders '対象フォルダ内のサブフォルダを順に取得 Call find_subFolder(s_fol.Path, フォルダ名3) '再帰処理 Next s_fol Set fso = Nothing End Sub 処理速度の懸念があります　Dir関数の方が処理が早いと思いますがご質問コードがfsoを使用していましたので準じます

Qchan1962 · Answer

こんにちは
実行コードを書いてくれる方が回答されているので深堀は不要かと思いますがご質問のコードを拝見するに　明らかにここは改善する必要があると思われるのはMyPathの取得方法で　If Dir(MyPath & フォルダ名3, vbDirectory)　です
ここでDir関数を使ってしまうとファイル名 = Dir()で問題が発生するような気がします（思い違いかも・・）

＞自分で色々調べて書いてみたのですが、再起処理が上手くできません。
再帰処理などで判らなくなった場合は、今一度なさりたい処理を整理して
フローチャートなどで確認するのが良いと思いますよ

メイン処理
Name folder1 & ファイル名 As MyPath & フォルダ名2
folder1は定数
ファイル名はDir関数で取得
MyPathはファイル名の一部の文字列でサブフォルダを探す
フォルダ名2はファイル名の一部を取得する（？拡張子は？）

つまり、メイン処理はMyPathが取得できた時にだけ実行すれば良い
サブフォルダパス（出力先パス）が取得できたか判別する為　別変数を用意する

メイン処理に必要なMyPathの取得は再帰処理が必要と思いますが
取得後　不要な処理を行わないように直ちに検索ループを抜けメイン処理をする

メイン処理を行った後Dir関数で次のファイルを対象に同じ処理を行い
folder1フォルダ内すべての*記録用*.xlsを処理をする

こんな感じでしょうか

tatsumaru77 · Answer

>日付と通し番号で始まり最後が記録用で終わるエクセルファイルが複数あります。
このファイル名の具体例を何件か提示していただけませんでしょうか。
（拡張子も含めて提示してください）

＞"C:\Users\owner\Desktop\A\B\"のサブフォルダーのサブフォルダーのさらにサブフォルダーに記録用のファイルと部分一致するサブフォルダーがあり

このサブフォルダの具体例を何件か提示していただけませんでしょうか。
また、部分一致するケースと一致しないケースの例も提示してください。

artoo · Answer

やりたい事を具体的に書かずに、上手く動かないプログラムを読んでそこからやりたいことをくみ取って、やりたいことが出来るようなプログラムを書いて欲しいというのはかなり無理がある質問です。
やりたいことを全部文章化できないのでしょうか？

あるフォルダーのファイルを違う親フォルダーのサブフォルダーに移したい

下記URLにアップしました。

No9です。

No8です。

No6です。

＃５です

No3です。

＃４一応 参考プロシージャ

こんにちは

>日付と通し番号で始まり最後が記録用で終わるエクセルファイルが複数あります。

やりたい事を具体的に書かずに、上手く動かないプログラムを読んでそこからやりたいことをくみ取って、やりたいことが出来るようなプログラムを書いて欲しいというのはかなり無理がある質問です。

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

＃４一応　参考プロシージャ