VBA サブフォルダ名をExcelファイルのセル値に変更したい

Question

お世話になります。

状況、試したこと：

1　複数のサブフォルダ内すべてにExcelファイルが保存されています。
2　Excelファイルのセル値（C9）から値を取得し、各サブフォルダ名を変更することを考えています。
3　サブフォルダ名をフルパスで指定することが困難であるため、Getfolder、ForNext構文を使用し、すべてのサブフォルダを探し、中のExcelファイルを取得し、フォルダ名を変更しようとしましたがスルーされてしまい動きません。
###イメージ：
〔全てのファイル保存先〕→〔A○○○○〕→Excelファイル
※〔全てのファイル保存先〕は親フォルダ。
※〔A○○○○〕はサブフォルダ。中にExcelファイルが入っている。このフォルダ名を変えたい。
###コード：

Sub()
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim wb As Workbook
Dim ws As Worksheet
Dim Target_Folder As Folder
Dim P_Folder As Folder
Dim File_Name As String
Dim Folder_Name As String
Dim Target_File As File

Set P_Folder = fso.GetFolder("\全ての受領データ保存先\")

 For Each Target_Folder In P_Folder.SubFolders
 For Each Target_File In Target_Folder.Files
   File_Name = Target_File.Name
  Folder_Name = Target_Folder.Name
  
If File_Name = "*.xlsx" Then
  Workbooks(File_Name).Activate
    Folder_Name = ActiveWorkbook.ActiveSheet.Range("C9").Value
    File_Name = ActiveWorkbook.ActiveSheet.Range("C9").Value
  End If

 Next
 Next 
Set fso = Nothing

End Sub

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

Answer 1

フォルダ名を変更しようとしましたがスルーされてしまい動きません。

現状のコードにはどこにもフォルダー名を変更するコードがありません。スルーされているのではなく処理自体がないので何もおきないのです。

やりたいことは下記のようなことでしょうか。

サブフォルダ内になるエクセルファイルを開いて、その最初のシートのC9セルの値を取得して、その値でサブフォルダー名を変更する。

もし、そうなら、このようなことは不可能です。
エクセルファイルを開いていたら、そのサブフォルダーの名前は変更できません。

エクセルファイルを開いてC9セルの値を取得したら、それと変更前のサブフォルダー名をいったん配列に格納します。その後エクセルファイルは閉じます。
その後、配列をループしながら、サブフォルダー名を変更する。

というような設計にする必要があるでしょう。

エクセルファイルを開かずにシートの値を取得する方法もありますが、その場合もいったん配列に格納してから処理するほうがいいでしょう。
サブフォルダーを探索中に、その名前を変更するのは、危険ですので。

Comments

[debiranian]

確かにおっしゃるとおりでした。
設計を今一度考えなおしてみます。
ありがとうございました。

Answer 2

完全な解決ではないと思いますが

If File_Name = "*.xlsx" Then
  Workbooks(File_Name).Activate
    Folder_Name = ActiveWorkbook.ActiveSheet.Range("C9").Value
    File_Name = ActiveWorkbook.ActiveSheet.Range("C9").Value
  End If

の部分を

If File_Name Like "*.xlsx" Then
    
    Application.ScreenUpdating = False
    
    Set wb = Workbooks.Open(Target_Folder + "\" + File_Name, ReadOnly:=True)
    Target_Folder.Name = wb.ActiveSheet.Range("C9").Value
    wb.Close
    
    Application.ScreenUpdating = True
    
End If

このようにすれば求めている結果に近づく気がします。
このコードですと変更しようとしている名前のフォルダが既にある場合にエラーになる等の問題も残ります。

Comments

[debiranian]

無事にできました！
私が思い描いていた動きをしてくれて感動しました。
このマクロに関係する事務において、同名の名称が存在することはないので問題ありません！
一層の勉強を重ねていきたいと思います。
ありがとうございました。