(VBA) 多階層のフォルダーの配置換え

質問

VBA　多階層のフォルダーを配置換えする
2021/07/13 16:54
以下のような操作をEXCELのVBAで処理可能でしょうか　？

---------------------
例えば、
添付画像のような階層が深いフォルダーの各層の最後に存在している
AAABBB,CCC,DDD,EEEの各フォルダーを#testに引き上げる。

ターゲットは、フォルダーでファイルではありません。

1段下層のフォルダーを引き上げるBATなどは検索すれば見つかりますが
階層が深い（多階層）の場合を見つけられませんでした。
（ファイルの場合は少し見つかりましたがフォルダーは見つけられませんでした。）

具体的には
O:\#test\AAA
O:\#test\#2\BBB
O:\#test\#2\#3\CCC
O:\#test\#2\#3\DDD
O:\#test\#2\#3\#4\EEE
を
O:\#test\AAA
O:\#test\BBB
O:\#test\CCC
O:\#test\DDD
O:\#test\EEE
に配置換えする

配置換え後は、O:\#test\#2及＃2以降の下層のフォルダーは削除する。

---------------------

回答No.18

kkkkkm · ベストアンサー

> B列とC列が同じになる場合にC列にはパスを表示しないはずなのに
> 9行目でB,C行共に同じなのにC列が表示されています。

OがB1は小文字でB2からは大文字だったのを見逃してました。
B列とC列の比較時に両方ともすべて小文字して比較するようにしました。
セルへの代入は大文字小文字今まで通りです。

If mCount = 1 And _
Cells(i, "B").Value <> Range("B1").Value & "\" & fso.GetFolder(Cells(i, "B").Value).Name Then
Cells(i, "C").Value = Range("B1").Value & "\" & fso.GetFolder(Cells(i, "B").Value).Name
End If

の部分を
Dim FName As String
を追加して

FName = Range("B1").Value & "\" & fso.GetFolder(Cells(i, "B").Value).Name
If mCount = 1 And _
StrConv(Cells(i, "B").Value, vbLowerCase) <> StrConv(FName, vbLowerCase) Then
Cells(i, "C").Value = FName
End If

に変更してください。

お礼

改正コード提示、ありがとうございます。

コードを修正して、検証した結果
　下記のようにパスが修正できました。

https://imgur.com/VdHPbQ0

これで、サンプルディレクトリーでの検証が出来たので
　ホントのディレクトリーでの改名に入りたいと思います。

ホントのディレクトリーで又新たな問題などが有りましたら
　新規に質問するかもしれませんが今回は終了とさせてください。

今回も長々とお付き合い頂き感謝いたします。

回答No.7

kkkkkm

訂正です

> O:\#test\#2\#3\BBB\#4\FFF
> のような階層のパスがあると
> O:\#test\#2\BBB
> は無視されます。

これは無視されない感じです。

回答No.6

kkkkkm

No5の補足です

不用になったフォルダは手動で削除するか、移動が終わった後でフォルダの中でサブフォルダがあるフォルダを削除するようにすればいいのではないかと思えます。

回答No.5

kkkkkm

ベストな方法かどうかは分かりませんが

B1にO:\#testが入っているとして

Private Sub listSubFolders
の
Cells(n, "B").Value = Replace(fol.Path, PATH_, "")
を
Cells(n, "B").Value = Range("B1").Value & Replace(fol.Path, PATH_, "")

に変更します。最下層フォルダー名取り出しにフルパスが必要な為と最後の移動にこのデータを使うため

B列に
O:\#test\#2
O:\#test\#2\#3
O:\#test\#2\#3\#4
という移動しないフォルダも出るのでC列に最下層として表示しないようにします。
B列のリストの各々パスの最後のフォルダ名がB列のリストで一度しか出現しないものを移動対象とします。

なので

O:\#test\#2\#3\BBB\#4\FFF
のような階層のパスがあると
O:\#test\#2\BBB
は無視されます。

Sub ②最下層フォルダー名()
Dim fso As Object, i As Long, mCount As Long
Dim LastRowsCount As Long
LastRowsCount = Cells(1, "B").End(xlDown).Row

Set fso = CreateObject("Scripting.FileSystemObject")
For i = 2 To LastRowsCount
mCount = WorksheetFunction.CountIf(Range(Cells(2, "B"), Cells(Rows.Count, "B").End(xlUp)), "*" & fso.GetFolder(Cells(i, "B").Value) & "*")
Cells(i, "F").Value = mCount
If mCount = 1 Then
Cells(i, "C").Value = Range("B1").Value & "\" & fso.GetFolder(Cells(i, "B").Value).Name
End If
Next
Set fso = Nothing
Range("A:E").EntireColumn.AutoFit
End Sub

これでB列に移動元、C列に移動先がセットされます。
間違いがなければ回答No.2で紹介されていたMoveFolderを使います。

Sub 移動()
Dim fso As Object, i As Long
Dim LastRowsCount As Long

Set fso = CreateObject("Scripting.FileSystemObject")
LastRowsCount = Cells(Rows.Count, "C").End(xlUp).Row

For i = 2 To LastRowsCount
If Cells(i, "C") <> "" Then
fso.MoveFolder Cells(i, "B").Value, Cells(i, "C").Value
End If
Next
Set fso = Nothing
End Sub

不用になったフォルダは手動で削除するか、F列にフォルダ名が出た回数を出しているのでそれの最大の行に該当するB列の対象フォルダを削除するコードで対応してください。質問のデータの場合O:\#test\#2が最大になっていると思います。

回答No.4

m5048172715

もう答えの回答がついたかな？

もし私がコーディングするなら？と考えてみました。VBAをいじっていたのは何年も前だったのでもうよく覚えていない。しかしなんとかしなくちゃ・・・

ということで、目標のディレクトリに共通する最も深いパス、質問文で言うと、
O:\#test\#2
をカレントディレクトリにして、DOSコマンドでファイル一覧を出し、結果をリダイレクション、その結果ファイルを解析します。VBAからDOSコマンドを実行できたと私は思いました。

OSがWindowsなら、コマンドは、
dir /s/ad /b > sumdir.txt
でしょう。

VBAでsumdir.txtを加工・ファイル処理する。ディレクトリを移動するバッチファイルをVBAで作ってそれを実行もできそうな感じはします。

私の途中までの実験では、そのコマンドは、ファイルを抜かしてディレクトリだけ表示してます。

お礼

DOSコマンドの提示ありがとうございます。

今回はフルパスのリストは、VBAで作成できましたが
DOSコマンドは次回利用できそうなので覚書に記録しました。

回答No.3

kkkkkm

最下層のフォルダ名は
たとえばフォルダのリストが
A1=O:\#test\AAA
A2=O:\#test\#2\BBB
A3=O:\#test\#2\#3\CCC
A4=O:\#test\#2\#3\DDD
A5=O:\#test\#2\#3\#4\EEE
となっていた場合、B列に最下層のAAA,BBB,CCC,DDD,EEEを表示します。
https://okwave.jp/qa/q9901225.html
の時に使った.GetFolder().Nameを使います。

Sub Test()
Dim fso As Object, i As Long

Set fso = CreateObject("Scripting.FileSystemObject")
For i = 1 To 5
Cells(i, "B").Value = fso.GetFolder(Cells(i, "A").Value).Name
Next
Set fso = Nothing
End Sub

お礼

kkkkkmさん、毎回のアドバイス感謝いたします。

アドバイスを受けて以下のコードまで作成できました。
下記画像を参照下さい。

参照画像（最下層フォルダ名抜き出しまで）
https://imgur.com/fHSEfzG
---------------------------------------------------------
Option Explicit
Private PATH_ As String ' 一覧を作成するルートフォルダーのフルパス
Public Sub ①フルパスフォルダー名()
Dim fso As Scripting.FileSystemObject
Dim n As Long ' 書き出しを行う行番号

Range("A1") = "ターゲット"

n = 1
PATH_ = Cells(n, "B").Value
n = n + 1
Set fso = New FileSystemObject
On Error GoTo ErrHndl
listSubFolders fso.GetFolder(PATH_), n

ExitSub:
Set fso = Nothing
Exit Sub

ErrHndl:
MsgBox Err.Description
Err.Clear
GoTo ExitSub
End Sub

Private Sub listSubFolders(ByVal folder_ As Scripting.Folder, ByRef n As Long)
Dim fol As Scripting.Folder
For Each fol In folder_.SubFolders
Cells(n, "B").Value = Replace(fol.Path, PATH_, "")
n = n + 1
listSubFolders fol, n
Next
Set fol = Nothing
End Sub
Sub ②最下層フォルダー名()
Dim fso As Object, i As Long
Dim LastRowsCount As Single
LastRowsCount = Cells(1, "B").End(xlDown).Row

Set fso = CreateObject("Scripting.FileSystemObject")
For i = 1 To LastRowsCount
Cells(i, "C").Value = fso.GetFolder(Cells(i, "B").Value).Name
Next
Set fso = Nothing
Range("A:E").EntireColumn.AutoFit
End Sub
------------------------------------------
後は、以前作成した以下のコードが利用できそうですが
変名したいフォルダーのみA列にマーク（○）を入れるようにしたのと、
フォルダー構造が違うので試行錯誤していますが上手く処理出来ていません。

（B2セルのフォルダー名にC列の内A列に○を付けたフォルダー名のみを
　＆で連結して変名するのですがコードが出来ていません。）

Sub ⑤フォルダー名の変更()

Dim i As Long
Dim LastColumn As Single
Dim LastColumn_ABC As String
Dim MSG As String

LastColumn = Cells(5, "A").End(xlToRight).Column
LastColumn_ABC = Split(Cells(1, LastColumn).Address, "$")(1)

MSG = MsgBox("B列フォルダー名が" & LastColumn_ABC & "列フォルダー名に変更されます！" & vbCrLf _
& "B," & LastColumn_ABC & "列に値がなければ、処理は行いません。", 257, "フォルダー名変更")

If MSG = vbCancel Then Exit Sub

i = 5 'subフォルダ名取得が5行目からフォルダー名を表示するため。

Do While Range("b" & i).Text <> ""

If Cells(i, LastColumn).Text <> "" Then ' 新フォルダー名がある場合のみ、名前変更を行う。
With CreateObject("Scripting.FileSystemObject")
.GetFolder(Range("A2").Text & Range("B" & i).Text).Name = Cells(i, LastColumn).Text
End With
End If

i = i + 1

Loop

MsgBox "変名処理が終了しました。"
End Sub
---------------------------------------------------------

回答No.2

imogasi

https://whiteleia.com/%E3%82%A8%E3%82%AF%E3%82%BB%E3%83%AB-vba-%E3%83%95%E3%82%A9%E3%83%AB%E3%83%80-%E7%A7%BB%E5%8B%95/
FSOですが、この記事を読んで、MoveFoldeメソッドでできませんか。
誤って、構成を崩したくないので、コピーなど取って、テストは慎重に行ってください。
模擬データ状態をつくりづらいので、言うだけで、すみません。

お礼

回答、ありがとうございます。

紹介いただいたサイトは私には理解が難しいです。

イメージとしては、下記のURLが参考になるのですが
https://happy-tenshoku.com/post-1489/

取得できるのがフォルダー名でフルパスでは無いので
他に参考になるサイトをサーチ中です。

補足

以下がフルパスを取得するのに参考になりそうです。

https://www.relief.jp/docs/excel-vba-recursive-list-folders.html

回答No.1

m5048172715

可能だろう。VBAを使ってプログラマは、例えば、
O:\#test\#2\#3\#4\EEE
という文字列を取得できる。たぶん。

ので、それを、
O:\#test\EEE
と変換すれば良いだけだから。そのアルゴリズム・方針は、2番目の/の次～最後の/の手前を削除となる。

補足

回答ありがとうございます。

>文字列を取得できる

　　では、最初にApplication.FileDialog(msoFileDialogFolderPicker)で
　　ターゲットフォルダーを指定して
　　それぞれ各層にある最後のフォルダーのフルパスを取得するにはどのようなコードを利用しますか　？

　　フォルダーの変名については、コードを作れそうですが
　　　フルパスの取得がネックになりそうです。