エクセル VBA ファイル名削除

フォルダーにはいっている複数のファイル名を変更するVBAを教えてください
ファイル名はすべて違います
例えば以下のような名前だとして、アンダーバーの５個目から前を削除したいです。
つまり、1-1_202105 , 2-2-(2)_202105 をファイル名としたいのですが、
残したい部分の文字数は一定ではありません。
また削除したい文字数も一定ではありません。初めからからアンダーバー5個目までを削除すると、新ファイル名となります。

F30002_A5987_GY002((2))_DQ0_(1)_1-1_202105
F30001_A5789_GY001-1_DD1_(2)_2-2-(2)_202105

ファイルの数も月によってまちまちですが、１０くらいあります。
ちなみに拡張子を一括で変換するVBAをフォルダー内で実行してから
ファイル名の変換をします。（拡張子変換のVBAは作成済）
お分かりの方よろしくお願いいたします。

No.1 ベストアンサー 回答者： tatsumaru77 回答日時： 2021/06/28 11:56

以下のスクリプトを登録してください。

Option Explicit
Public Sub ファイル名一括変更()
Dim fname As String
Dim old_name As String
Dim new_name As String
Const folder As String = "d:\goo\data"
Dim RE As Object
Dim matches As Object
Dim match As Object
Set RE = CreateObject("VBScript.RegExp")
RE.Pattern = "^([^_]+_[^_]+_[^_]+_[^_]+_[^_]+_)(.+)$"
RE.Global = True

Dim FSO As Object
Dim FO As Object
Dim get_files As Object
Dim get_file As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FO = FSO.GetFolder(folder)
Set get_files = FO.files
For Each get_file In get_files
fname = get_file.Name
Set matches = RE.Execute(fname)
If matches.Count > 0 Then
Set match = matches.Item(0)
old_name = folder & "\" & fname
new_name = folder & "\" & match.submatches(1)
MsgBox ("old=" & old_name & vbLf & "new=" & new_name)
Name old_name As new_name
End If
Next
MsgBox ("完了")
End Sub

-------------------------------------
使用時の注意事項
Const folder As String = "d:\goo\data"
は、該当フォルダ名です。あなたの環境にあわせて適切に設定してください。

最初は、試験的にテスト用のフォルダを作り、そこに少量のファイルを格納し、
正しくリネームされるか確認してください。
MsgBox ("old=" & old_name & vbLf & "new=" & new_name)
で変更前のファイル名と変更後のファイル名をメッセージボックスに表示しています。ファイルが大量にある場合は、この行をコメントアウトしてください。

この回答へのお礼

この式の一部が赤くなり、構文がちがうみたいです。
うまくいきませんでした。ちょっと考えます
ありがとうございました。

お礼日時：2021/07/02 21:29

No.5 回答者： googoo900 回答日時： 2021/07/05 23:11

下記のサイトにファイル名取得およびファイル名変更のマクロがあります。

両方を実行できるように標準モジュールに取り込んでおきます。
https://www.higashisalary.com/entry/file_rename


■手順
１．拡張子の一括変換を行います。
２．取り込んだファイル名取得のマクロを実行します。そうするとA4セル以降にファイル名が取得されます。
３．A5セルに『=IFERROR(MID(A4,SEARCH("_",A4,SEARCH("_",A4,SEARCH("_",A4,SEARCH("_",A4,SEARCH("_",A4,1)+1)+1)+1)+1)+1,LEN(A4)),A4)』と入力して下方向にコピペします。
４．取り込んだファイル名変更のマクロを実行します。そうするとファイル名が変更されます。

※１　ファイル名にアンダーバーが５つ以上ない場合は、ファイル名変更対象外としています。
※２　練習用フォルダに練習用ファイルを作成して試しておくことをお勧めします。

この回答へのお礼

ありがとうございました。
会社で、このサイトは見れないので、後ほど　試してみます。

お礼日時：2021/07/06 19:55

No.4 回答者： tatsumaru77 回答日時： 2021/07/03 07:46

No1です。

＞この式の一部が赤くなり、構文がちがうみたいです。

この式とは、具体的にどの行ですか。
私が提示したマクロは、こちらで動作確認済みのものです。
あなたが、マクロを作成されたとき、コピペでなく手打ちで作成された場合、スペルミスが考えられます。手打ちで作成されたのでしょうか。

この回答へのお礼

こんにちは
コピペしました。RE patternからの一文と　new_nameからの一文が赤くなります。コンパイルエラーと出てきます。
私の方で、何かしたのかと思いますが　今回は、諦めます。
ありがとうございました。

お礼日時：2021/07/06 19:54

No.3 回答者： bonaron 回答日時： 2021/06/28 16:44

・アンダーバーが４個以下の場合

・削除した結果、同名のファイルが発生
どちらもあり得ないものとして
新ファイル名を求めるところだけ。

Dim a As Variant
Dim b As String
Dim nm As String
b = "F30002_A5987_GY002((2))_DQ0_(1)_1-1_202105"
a = Split(b, "_", 6, vbBinaryCompare)
nm = a(5)

この回答へのお礼

元のファイル名は10くらいあるんですが、それを全部構文にいれるということですよね。まだ試してないですが、やってみます。ありがとうございました

お礼日時：2021/07/02 21:31

No.2 回答者： nicotinism 回答日時： 2021/06/28 13:07

スプリット関数では？

説明しやすくするためにファイル名を簡略化して
"1_2_3_4_5_6_7"とします。
Dim v as variant
v=split("1_2_3_4_5_6_7","_") これで（添字の既定の最小値は 0）
v(0)=1・・・v(4)=5 ・・・などと配列に格納できます。

例示されたようにアンダーバーの個数が固定であれば
FileName="F30001_A5789_GY001-1_DD1_(2)_2-2-(2)_202105"
v=split(FileName,"_")
newFileName=v(5) & "_" & v(6)
で得られます。

アンダーバーの個数が不定なら、Ubound(V) で配列数が得られるので
あとはFor ～ Next ループとかでしょうかね。

この回答へのお礼

うまくいきそうですが、これを私のものに当てはめるのが厄介な気がします。ありがとうございました

お礼日時：2021/07/02 21:30