フォルダー名変更(指定文字を移動、削除)

質問

当初、フォルダー名変更ソフトでフォルダー名の変更を考えていましたが
ソフトカテゴリーで回答が付かなかった。

EXCELのVBAを利用して変名出来る方法を教えて下さい。

指定ディレクトリーのフォルダー名を取得して
下記条件で変名後にフォルダー名を書き出す。

------------------------------------------------------------------------
フィルダー名の先頭からX文字目からXX文字目までの指定文字列（ABS)を
　フォルダー名の先頭に追加して、指定文字列（ABS)は削除する。
(X,XXは任意指定）

例えば、ｘ＝先頭の5文字目から、XX＝3文字をだとすると

　　testABSmoji ---> ABStestmoji

------------------------
逆に
　フォルダー名最後部からX文字目からXX文字目までの指定文字列（oem)を
　フォルダー名の先頭に追加して、指定文字列（oem)は削除する。
(X,XXは任意指定）

例えば、ｘ＝最後尾の1文字目から、XX＝4文字をだとすると

　　TEST＿TEST＿oemm　---＞　oemmTEST_TEST＿

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

議事録の保存形式が年度によって（又は担当者によって）異なるので
作成年月日でソートを行うことが現在で来ていません。
180224（2018年2月24日）をフォルダー名の先頭に来るようにしたい。

回答No.9

Qchan1962 · ベストアンサー

しつこくて申し訳ありません。
閉じていなかったので覗いてしまいました。
＃７の補足を読んでしまいましたので、、つい
無視していただいて結構ですが、＃５のコードに追加しました。

Sub sample1()
'Microsoft Scripting Runtime 参照設定
Dim FSO As FileSystemObject
Dim Fol As Folder, sfl As Folder
Dim pF As String, pcnt As Integer
Dim Ft As Integer, cnt As Integer
Dim buf As String, RE, reMatch, reValue
　 Set FSO = New FileSystemObject
　 With Application.FileDialog(msoFileDialogFolderPicker)
　　 .InitialFileName = CreateObject("WScript.Shell").SpecialFolders("desktop")
　　 If .Show = True Then
　　　　pF = .SelectedItems(1) & "\"
　　 End If
　 End With
　 If pF = "" Then Exit Sub
　 Ft = Application.InputBox(Prompt:="左から何番目の4桁ですか？", Type:=1)
　 If Ft = 0 Then Exit Sub
　 Set Fol = FSO.GetFolder(pF)
　 On Error Resume Next
　 For Each sfl In Fol.SubFolders
　　 cnt = 1
　　 buf = sfl.Name
　　 With CreateObject("VBScript.RegExp")
　　　　.Pattern = "\d+"
　　　　.Global = True
　　　　Set reMatch = .Execute(buf)
　　　　If reMatch.Count > 0 Then
　　　　　 For Each reValue In reMatch
　　　　　　 If Len(reValue) = 4 Then
　　　　　　　　If Ft = cnt Then
　　　　　　　　　 buf = reValue & Replace(buf, reValue, "")
　　　　　　　　　 pcnt = pcnt + 1
　　　　　　　　End If
　　　　　　　　cnt = cnt + 1
　　　　　　 End If
　　　　　 Next reValue
　　　　End If
　　 End With
　　 sfl.Name = buf
　 Next
　 Set FSO = Nothing
　 If pcnt > 0 Then
　　 MsgBox (pcnt & "件処理をしました。")
　 Else
　　 MsgBox (cnt & " 番目の4桁数字を見つけられませんでした。")
　 End If
End Sub

参考まで

お礼

>しつこくて申し訳ありません。

いえいえ、そんな事は少しも思っていません。
マクロを書いていただく初心者の私には大変嬉しいです。

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

「ファイル名に4桁の数字が２か所以上ある」のコードありがとうございます。

（検証して4桁に数字が先頭に移動するのを確認しました。）

こちらのコードは、他の用途に利用できそうなので
　横型配置＋同コピペ方式のマクロコードと共にこれから利用させていただきます。

最後までお付き合い願い改めてお礼申し上げます。

回答No.10

SI299792

回答No.7のプログラムですが、必ず６桁の数字があることを前提にしています。
６桁の数字がないものに関してじは、ファイル名が変換されたりされなかったりします。また、全てのファイル名の６桁の数字が同じ位置にあることが前提です。

４桁なら最初からそう書いて下さい、と言いたい所ですが、これは私が先走って頼まれてもいないのに付けた機能なので文句は言えません。
　　RegExp.Pattern = "\d{4}"
にすれば、４桁の数字の位置を表示するようになりますが、今度は４桁の数字のないものが、変換されたりされなかったりします。
４桁に固定していいのか、４桁６桁両対応にする必要があるのか。

私の所では、全てのフォルダに６桁の数字が同じ位置にあれば正しく動きます。もし全てのフォルダに６桁の数字が同じ位置にあるのに正しく動かないのであれば、詳細を書いていただけますか。

回答No.8

Qchan1962

＞10種類ほどのパターンがあります。
パターン化されたフォルダーを個別に仕分けしてホルダーに格納して
初めからパターンを示して頂ければ、一気にできると思いますが、、

＞S1299792さんのNo4の回答にある横型配置＋同コピペ方式で処理が高速になりそうなメドが立ちました。

何よりで良かったです。

スレッドお借りして恐縮ですが、、
また、余計なお世話かもしれませんが、＃７さん　まだリネームに不具合があるように思いますが、、見直して見てくださいね。

回答No.7

SI299792

回答No.6、バグあり、差し替えです。

Option Explicit
'
Sub Macro1()
　　Dim PathName As String
　　Dim FileName As String
　　Dim Start As Integer
　　Dim RegExp As Object
　　Dim Execute As Object
'
　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　.Title = "フォルダを選択"
'
　　　　If Not .Show Then
　　　　　　End
　　　　End If
　　　　PathName = .SelectedItems(1) & "\"
　　End With
'
　　FileName = Dir(PathName & "*.", vbDirectory)
　　Set RegExp = CreateObject("VBScript.RegExp")
　　RegExp.Pattern = "\d{6}"
'
　　While FileName > ""
'
　　　　If Start = 0 Then
　　　　　　Set Execute = RegExp.Execute(FileName)
'
　　　　　　If Execute.Count > 0 Then
　　　　　　　　Start = Execute(0).FirstIndex + 1
　　　　　　　　Start = "0" & InputBox(FileName, _
　　　　　　　　　　"開始位置が違っていれば修正して下さい", Start)
'
　　　　　　　　If Start = 0 Then
　　　　　　　　　　End
　　　　　　　　End If
　　　　　　End If
　　　　End If
'
　　　　If Start > 0 Then
　　　　　　Name PathName & FileName As PathName & Mid(FileName, Start, 6) & _
　　　　　　　　Left(FileName, Start - 1) & Mid(FileName, Start + 6)
　　　　End If
　　　　FileName = Dir
　　Wend
'
　　If Start = 0 Then
　　　　MsgBox "６桁の数字のあるフォルダはありませんでした", vbCritical
　　Else
　　　　MsgBox "終了しました"
　　End If
End Sub

補足

せっかくコードを提示して頂いたので、
　「ファイル名に６桁の数字が２か所以上ある」場合の想定では無く

　「ファイル名に4桁の数字が２か所以上ある」想定でのコードで修正いただければ幸いです。

--------------------------------
残念ですが、＃7の
提示いただいたマクロをそのままコピペして
　　親のサンプルフォルダーにいくつかターゲットフォルダーを入れてチェックしてみましたが

#8のQchan1962さんのコメントにもありますように
　マクロを起動させてもリーネームが上手く出来ません。

回答No.6

SI299792

ファイル名に６桁の数字が２か所以上あるなら、このような方法でどうでしょうか。
プログラムを動かすと、親フォルダを選択します。すると、最初の子フォルダから、６桁の数字を探して場所を表示します。それでよければそのままOK、違っていれば手作業で場所を指定。以下、最初の入力に従って処理されます。場所指定の手間は軽減されると思います。

Option Explicit
'
Sub Macro1()
　　Dim PathName As String
　　Dim FileName As String
　　Dim Start As Integer
　　Dim RegExp As Object
　　Dim Execute As Object
'
　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　.Title = "フォルダを選択"
'
　　　　If Not .Show Then
　　　　　　End
　　　　End If
　　　　PathName = .SelectedItems(1) & "\"
　　End With
'
　　FileName = Dir(PathName & "*.", vbDirectory)
　　Set RegExp = CreateObject("VBScript.RegExp")
　　RegExp.Pattern = "\d{6}"
'
　　While FileName > ""
'
　　　　If Start = 0 Then
　　　　　　Set Execute = RegExp.Execute(FileName)
'
　　　　　　If Execute.Count > 0 Then
　　　　　　　　Start = Execute(0).FirstIndex + 1
　　　　　　　　Start = "0" & Start = "0" & InputBox(FileName, _
　　　　　　　　　　"開始位置が違っていれば修正して下さい", Start)
'
　　　　　　　　If Start = 0 Then
　　　　　　　　　　End
　　　　　　　　End If
　　　　　　End If
　　　　End If
'
　　　　If Start > 0 Then
　　　　　　Name PathName & FileName As PathName & Mid(FileName, Start, 6) & _
　　　　　　　　Left(FileName, Start - 1) & Mid(FileName, Start + 6)
　　　　End If
　　　　FileName = Dir
　　Wend
'
　　If Start = 0 Then
　　　　MsgBox "６桁の数字のあるフォルダはありませんでした", vbCritical
　　Else
　　　　MsgBox "終了しました"
　　End If
End Sub

回答No.5

Qchan1962

＞フォルダーの中には、数値が2箇所以上有る場合があるので必要な数字が
　　最初の数字とか後からの数字とか一概に判断できず
　　最終的には
　　人間の判断が必要となり一概に数値を見つけて書き出して処理は
　　上手く処理できません。

つまり、規則性が無いと理解して良いのでしょうか？
＞数値が2箇所以上有る場合が
3か所も可能性があるのなら、最初からでも後から操作しても
一様な処理は出来ないと思いますが、、

一応、6桁の数値を判断して先頭に持ってくる場合は、条件を1つ加えるだけです。
Sub sample1()
'Microsoft Scripting Runtime 参照設定
Dim fso As FileSystemObject
Dim Fol As Folder, sfl As Folder
Dim pF As String
Dim Ft As Integer, Trg As Integer
Dim buf As String, RE, reMatch, reValue
　 Set fso = New FileSystemObject
　 With Application.FileDialog(msoFileDialogFolderPicker)
　　 .InitialFileName = CreateObject("WScript.Shell").SpecialFolders("desktop")
　　 If .Show = True Then
　　　　pF = .SelectedItems(1) & "\"
　　 End If
　 End With
　 If pF = "" Then Exit Sub
　 Set Fol = fso.GetFolder(pF)
　 On Error Resume Next
　 For Each sfl In Fol.SubFolders
　　 buf = sfl.Name
　　 With CreateObject("VBScript.RegExp")
　　　　.Pattern = "\d+"
　　　　.Global = True
　　　　Set reMatch = .Execute(buf)
　　　　If reMatch.Count > 0 Then
　　　　　 For Each reValue In reMatch
　　　　　 If Len(reValue) = 6 Then '6桁が複数ある場合、後の6桁が前に来ます。
　　　　　　 buf = reValue & Replace(buf, reValue, "")
　　　　 End If
　　　　　 Next reValue
　　　　End If
　　 End With
　　 sfl.Name = buf
　 Next
　 Set fso = Nothing
MsgBox ("完了")
End Sub

お礼

何度もありがとうございます。

>つまり、規則性が無いと理解して良いのでしょうか？

年度や記載担当者によって記載方法が変わっていますが
　全く規則性が無い訳ではではなく10種類ほどのパターンがあります。

パターン化されたフォルダーを個別に仕分けしてホルダーに格納して
S1299792さんのNo4の回答にある横型配置＋同コピペ方式で処理が高速になりそうなメドが立ちました。

Qchan1962さん、最後までお付き合い願いありがとうございます。

改めてお礼申し上げます。

回答No.4

SI299792

ダイアログボックスで開くようにしました、同時に若干仕様変更しました、
開始位置はB2、文字数はC2に入力してください。
というのは、いろいろなパターンがあるでしょうから、それを入力しておきます。実行時にB2～C2へコピペすれば、指定が楽になります。
他の方が既に上げてますが、私も一応上げます。

Option Explicit
'
Sub Macro1()
　　Dim PathName As String
　　Dim OldName As String
　　Dim NewName As String
　　Dim Length As Long
'
　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　.Title = "フォルダを選択"
'
　　　　If Not .Show Then
　　　　　　End
　　　　End If
　　　　PathName = .SelectedItems(1) & "\"
　　End With
'
　　OldName = Dir(PathName & "\*.", vbDirectory)
'
　　While OldName > ""
　　　　NewName = ""
'
　　　　If Left(OldName, 1) = "." Then
　　　　ElseIf [B2] > 0 Then
　　　　　　NewName = Mid(OldName, [B2], [C2]) & _
　　　　　　　 Left(OldName, [B2] - 1) & Mid(OldName, [B2] + [C2])
　　　　Else
　　　　　　Length = Len(OldName)
　　　　　　NewName = Right(OldName, [C2]) & Left(OldName, Length - [C2])
　　　　End If
'
　　　　If NewName <> "" Then
　　　　　　Name PathName & OldName As PathName & NewName
　　　　End If
　　　　OldName = Dir
　　Wend
　　MsgBox "終了しました"
End Sub

最初に作った時は思い至らなかったのですが、多分このフォルダはこの位置というのは決まっているのではないですか。であれば、ミスを防ぐためにダイアログボックスはやめて、私が最初に上げたプログラムで、
[B1]→[A2]
[B3]→[C2]
と痴漢すれば、フォルダ名、開始位置、文字数を横並びにできます。
下に、一覧を作っておき、必要に応じて２行目にコピペするという方法もあります。

＞フォルダーの中には、数値が２箇所
６桁の数字が２か所以上にあるのならやむ負えません。
普通はそんなに長いファイル名を付けないと思います。もし、日付以外の数字が６桁でないなら、自動判断は可能です。

お礼

>多分このフォルダはこの位置というのは決まっているのではないですか。

そのとうりです。

No2さんの補足コメントにも記載しましたが

フォルダーの中には、数値が2箇所以上有る場合があるので必要な数字が
　　最初の数字とか後からの数字とか一概に判断できず
　　最終的には
　　人間の判断が必要となり一概に数値を見つけて書き出して処理は
　　上手く処理できません。

　　（つまり、どの位置に必要な数値があるかは、人間が判断して
　　　　めんどうでもそれぞれ別のホルダーにタイプ別に仕分けして
　　　　それぞれ別途処理することになります。）

>であれば、ミスを防ぐためにダイアログボックスはやめて

そうですね。
　最初のマクロを横型（横並び）に修正して
　一覧表を先に作っておいてコピペ（A2,B2、C2）して行くようにすれば処理は簡単になりますね。

私がマクロを使って処理する時は、最初のマクロを横型に修正したマクロを利用したいと思います。
EXCELに不慣れな人も処理で使う予定なので
　ダイアログボックスを使ったマクロも別途作成しておきたいと思います。

>日付以外の数字が６桁でないなら、自動判断は可能です。

心遣いありがとうこざいます。

現状、教えて頂いた処理コードで十分な処理速度アップが見込めるので
　今回は自動判断までは望みません。

------------------------------------------
問題も無事解決しました。

色々教えていただきありがとうございます。

回答No.3

Qchan1962

追加回答します。
＞逆に　？　不規則なのでしょうか？
＞180224（2018年2月24日）をフォルダー名の先頭に来るようにしたい。
取り敢えず、
180224　（など）がフォルダ名に含まれており、それを名前の頭に持ってくれば
良いのであれば、下記でいかがでしょう。

文字数などは設定不要、数値部分を抜き出し　名前頭に移動します。
（正しくは、削除して加える）
標準モジュール
Sub sample1()
'Microsoft Scripting Runtime 参照設定
Dim fso As FileSystemObject
Dim Fol As Folder, sfl As Folder
Dim pF As String
Dim Ft As Integer, Trg As Integer
Dim buf As String, RE, reMatch, reValue
　 Set fso = New FileSystemObject
　 With Application.FileDialog(msoFileDialogFolderPicker)
　　 .InitialFileName = CreateObject("WScript.Shell").SpecialFolders("desktop")
　　 If .Show = True Then
　　　　pF = .SelectedItems(1) & "\"
　　 End If
　 End With
　 If pF = "" Then Exit Sub
　 Set Fol = fso.GetFolder(pF)
　 For Each sfl In Fol.SubFolders
　　 buf = sfl.Name
　　 With CreateObject("VBScript.RegExp")
　　　　.Pattern = "\d+"
　　　　.Global = True
　　　　Set reMatch = .Execute(buf)
　　　　If reMatch.Count > 0 Then
　　　　　 For Each reValue In reMatch
　　　　　　 buf = reValue & Replace(buf, reValue, "")
　　　　　 Next reValue
　　　　End If
　　 End With
　　 sfl.Name = buf
　 Next
　 Set fso = Nothing
End Sub

補足

早速、訂正いただき感謝します。

以下の申し出ですが、

>180224　（など）がフォルダ名に含まれており、それを名前の頭に持ってくれば
>良いのであれば、下記でいかがでしょう。

NO1さんも以下のように数値検索して先頭に書き出すではだめなのか？
と申し出が有りましたが

>６桁の数字を検索してそれを銭湯（先頭）に移動するプログラムの方がいい気がします。
>そうすれば、位置を指定する必要がありません。

フォルダーの中には、数値が2箇所以上有る場合があるので必要な数字が
　　最初の数字とか後からの数字とか一概に判断できず
　　最終的には
　　人間の判断が必要となり一概に数値を見つけて書き出して処理は
　　上手く処理できません。

　　（つまり、どの位置に必要な数値があるかは、人間が判断して
　　　　めんどうでもそれぞれ別のホルダーにタイプ別に仕分けして
　　　　それぞれ別途処理することになります。）

回答No.2

Qchan1962

＞作成年月日でソートを
沢山あると言う事ですかね。
全フォルダを同じ規則でリネームすれば良いでしょうか？

標準モジュールに
Option Explicit
Sub sample()　’実行プロシージャ
'Microsoft Scripting Runtime 参照設定必須
Dim fso As FileSystemObject
　 Set fso = New FileSystemObject
　 Dim Fol As Folder, sfl As Folder
　 Dim pF As String
　 Dim Ft As Integer, Trg As Integer
　 With Application.FileDialog(msoFileDialogFolderPicker)
　　 .InitialFileName = CreateObject("WScript.Shell").SpecialFolders("desktop")
　　 If .Show = True Then
　　　　pF = .SelectedItems(1) & "\"
　　 End If
　 End With
　 If pF = "" Then Exit Sub
　 Set Fol = fso.GetFolder(pF)
　 Ft = Application.InputBox(Prompt:="start位置", Type:=1)
　 If Ft = 0 Then Exit Sub
　 Trg = Application.InputBox(Prompt:="文字数", Type:=1)
　 If Trg = 0 Then Exit Sub
　 For Each sfl In Fol.SubFolders
　　 sfl.Name = Name_change(sfl.Name, Ft, Trg)
　 Next
　 Set fso = Nothing
End Sub

Function Name_change(trgName As String, Ft As Integer, Trg As Integer) As String
Dim Ln As String, reName As String, Rn As String
　 Ln = Left(trgName, Ft - 1)
　 reName = Mid(trgName, Ft, Trg)
　 Rn = Right(trgName, Len(trgName) - (Ft + Trg) + 1)
　 Name_change = reName & Ln & Rn
End Function

親フォルダをダイアログで選択、例の場合、例の様に5、3とインプットボックスに入力してください。
すべてのフォルダを同じフォルダに入れて実行してください。
検証は、少ないフォルダでお願いします。
対象になったフォルダすべてが同じ規則で（リネーム）書き換えられます。
エラー処理は行っていません。

お礼

コードの提示感謝します。

先にコードを提示いただいたNO1さんの検証で
　Qchan1962さんのコードがUPされていたのに気づくのが遅くなりました。

コードを標準モジュールにコピペして検証を始めましたが、
　Dim fso As FileSystemObject　で
　　コンパイルエラー：ユーザー定義型は定義されていません。
　とエラーになります。

「Microsoft Scripting Runtime」をライブラリーに追加しないと行けないと気づいてエラーはなくなりました。

先頭から指定する場合は、上手く処理できました。
最後部から指定する処理がコードに無いと思うのですが？
　　出来ればNO1さんのようにstart位置に「0」（ゼロ）を指定した場合は
　　最後部からの処理であるとのFLAGを使えるようにできませんか　？

------------------------------------
FileSystemObjectでNO1さんにお願いした
　　ダイアログボックスが表示されてエキスプローラー感覚で
　　親フォルダーを指定する事ができるので嬉しいです。

回答No.1

SI299792

ディレクトリー、フォルダー、フィルダーなど、いろいろな表現をしていますが、
親フォルダーを指定して、その中の子フォルダーの名前を変えるという事ですね。
拡張子のついていないものをフォルダとみなして改名します。

まず、図の様に入力してください。
B1に親フォルダ名、
B2に銭湯に移動する文字の開始位置、但し、最後部からの場合は０
B3に銭湯に移動する文字数を指定して下さい。

testABSmoji →ABStestmoji
B2: 5　B3: 3

TEST＿TEST＿oemm　→oemmTEST_TEST＿
B2: 0　B3: 4

Option Explicit
'
Sub Macro1()
　　Dim OldName As String
　　Dim NewName As String
　　Dim Length As Long
'
　　OldName = Dir([B1] & "\*.", vbDirectory)
'
　　While OldName > ""
　　　　NewName = ""
'
　　　　If Left(OldName, 1) = "." Then
　　　　ElseIf [B2] > 0 Then
　　　　　　NewName = Mid(OldName, [B2], [B3]) & _
　　　　　　　 Left(OldName, [B2] - 1) & Mid(OldName, [B2] + [B3])
　　　　Else
　　　　　　Length = Len(OldName)
　　　　　　NewName = Right(OldName, [B3]) & Left(OldName, Length - [B3])
　　　　End If
'
　　　　If NewName <> "" Then
　　　　　　Name [B1] & "\" & OldName As [B1] & "\" & NewName
　　　　End If
　　　　OldName = Dir
　　Wend
End Sub

話を読んでいると、６桁の数字を検索してそれを銭湯に移動するプログラムの方がいい気がします。そうすれば、位置を指定する必要がありません。ファイル名の付け方が不明なので、この方法が有効かどうかわかりません。その方がよければ補足かお礼に書いて下さい。明日になるけど作ります。

お礼

マクロコードの提示ありがとうございます。

検証結果、思っていた処理が出来ました。

先頭からと最後部からの２つのマクロが必要と思っていましたが
最後部からの場合は０を指定するアイデアは「なるほど」と感心しました。

>６桁の数字を検索してそれを銭湯（先頭）に移動するプログラムの方がいい気がします。
>そうすれば、位置を指定する必要がありません。

フォルダーの中には、数値が2箇所以上有る場合があるので必要な数字が
　　最初の数字とか後からの数字とか一概に判断できず人間の判断が必要となります。

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

できればマクロを少し改造したいと思います。
　　B1セルで親フォルダーを指定していますが、
　　マクロを起動した時に最初に親フォルダーを指定する
　　ダイアログボックスが表示されてエキスプローラー感覚で
　　親フォルダーを指定するようにしたいです。

マクロコードの訂正ができればお願いします。

補足

お礼の書き込みでお願いした以下の追加の件ですが、

>マクロを起動した時に最初に親フォルダーを指定する
>ダイアログボックスが表示されてエキスプローラー感覚で
>親フォルダーを指定するようにしたいです。

NO2さんが「FileSystemObject」ライブラリーを利用する事で
　　希望のダイアログボックスがでました。

検討のほどお願いベースですがよろしくお願いします