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

タイトルに書きました通り、特定のフォルダーのファイルを違う親フォルダーのサブフォルダーに移動したいのですが、移動先がたくさんのフォルダーが階層になっていて上手く処理できません。

ファイル名と一致するサブフォルダーに移動したいのですが、このファイル名も半角スペースがたくさん入っていて冗長になっています。

自分で色々調べて書いてみたのですが、再起処理が上手くできません。

どうかお力をお貸しいただけませんか？

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

質問者からの補足コメント

• ご回答ありがとうございます。移動させたいファイルが暗号化ファイルであることと、移動先のサブフォルダがかなり階層化されていることからファイルを開かないで移動できればと思っております。

  No.1の回答に寄せられた補足コメントです。 補足日時：2023/02/15 22:14

• ご回答ありがとうございます。
  文章化させていただきます。
  "C:\Users\owner\Desktop\テスト用\"に日付と通し番号で始まり最後が記録用で終わるエクセルファイルが複数あります。
  "C:\Users\owner\Desktop\A\B\"のサブフォルダーのサブフォルダーのさらにサブフォルダーに記録用のファイルと部分一致するサブフォルダーがあり（サブフォルダーがない場合もあり、その際は移動しません）、そこにファイルを移動したいです。

  No.2の回答に寄せられた補足コメントです。 補足日時：2023/02/16 01:01

• ご丁寧にありがとうございます。教えていただいたコードですが、ファイル名=Dirのところでエラーになってしまうのですが、どうしたらいいのでしょうか？ファイル名を処理してフォルダー名3まではうまくいっています。

  No.5の回答に寄せられた補足コメントです。 補足日時：2023/02/17 01:24

• ご回答ありがとうございます。補足させていただきます。
  ファイル名
  200303 5678 ☆ ●●.xlsx
  221224 4321 ▲▲ ★.xlsx
  230216 1234 〇〇 △△.xlsx
  
  C:\Users\owner\Desktop\A\B
  BーTーFー○○ △△フォルダー
  　ーGーNー☆ ●●フォルダー
  
  Bフォルダー配下にファイル名を処理した変数フォルダ名3のフォルダーがなければ処理しません。
  
  説明分かりにくくなってしまいました。申し訳ありません。

  No.3の回答に寄せられた補足コメントです。 補足日時：2023/02/17 01:37

• ファイル名間違えました。すみません。
  200303 5678 ☆ ●● 記録用.xlsx
  221224 4321 ▲▲ ★ 記録用.xlsx
  230216 1234 〇〇 △△ 記録用.xlsx

    補足日時：2023/02/17 01:39

• 遅くなってしまい申し訳ございません。
  下記回答させていただきます。
  １．拡張子は.xlsxである。
  （拡張子が.xlsm .xls 等は移動対象外とする）
  →はい
  ②→通し番号は桁数固定です
  ③④→日付の後、通し番号の後は半角スペース1桁固定です
  ⑤→記録用の前の半角スペースは1桁のみです。
  ３．取得したフォルダ名３について
  取得したフォルダ名３の中に半角スペースが含まれることはありますか。
  例　200303□□5678□☆□●●□記録用.xlsx
  （半角１桁の空白を□で表しています）
  の場合、フォルダ名３は「☆□●●」になりますが、このようなケースはありますか。
  →多々あります。半角スペースが多くて3つ程あることがあります。

  No.6の回答に寄せられた補足コメントです。 補足日時：2023/02/20 00:31

• ４．サブフォルダについて
  →はい。もし一致するものがあった場合、そのフォルダーはSUB3にあります。
  ５．サブフォルダ名＝ABC〇〇△△△XYZ　・・・部分一致する
  →これについては△が一つ多いので不一致扱いです。取得したフォルダー名3と完全一致のものが対象です。
  ６．念のための確認
  ①　ファイル名の最後の３文字が「記録用」でない→はい対象外です
  →ファイル名は規則正しく付けられてるため②③④このようなケースはないかと思われます

  No.8の回答に寄せられた補足コメントです。 補足日時：2023/02/20 00:33

• １．ファイル名が以下のようなケースは移動対象外で良いですか。
  （半角１桁の空白を□で表しています）
  ①　200303□5678□☆●●記録用.xlsx　・・・「記録用」の前に空白がない
  →記録用の前に空白がないケースはありません
  ２．複数のフォルダが移動対象の候補として存在する時、どのフォルダに移動されるかは
  　不確定ですがよろしいでしょうか。（マクロが最初に検知したほうのフォルダになります）
  →フォルダーが存在する場合一つのみになります
  ３．移動先のフォルダに移動対象となるファイルが既に存在する場合は、
  移動を行いませんがよろしいでしょうか
  →はい

    補足日時：2023/02/20 00:47

• ご丁寧にありがとうございます。結果を確認できるのはとても助かります！VBAの勉強はまだまだ未熟なため色々なアプローチの方法を知っておきたいと思い補足させていただきました。宜しくお願い致します。

  No.10の回答に寄せられた補足コメントです。 補足日時：2023/02/20 12:18

No.1 回答者： NPO2000 回答日時： 2023/02/15 19:14

移動したいファイルを一旦開いて「名前を付けて保存」で好きなフォルダーに保存すればいいのではないですか。