(VBA) ファイル名の変更 - 拡張子を参考 -

質問

ファイル名の変更をEXCEｌ（VBA)で行いたいと思います。

以下を参考にしました
https://akira55.com/file_change_name/

旧ファイル名を新ファイル名に変更する場合、
　拡張子は旧ファイルと同じなので
　新ファイルには拡張子が無い形式で記載されています。

一応、上手く処理出来ているようでエラー無く完了しますが、
　問題があります。

拡張子を取り出すのに"."から右側を取り出していますが
"."が複数ある場合は処理できません。

　"."が複数ある場合、最後の"."から右側を取り出すようにようにするには
　どのようにコードを変更しますか　？

Sub FilenameChange01() '指定したファイル名を変更します。

Dim ws01 As Worksheet
Dim lRow, I As Single
Dim FolderName, OldFile, NewFile As String
Dim OldFile_Kakucyoushi, NewFile_Kakuchoushi As String

Set ws01 = Worksheets("ReName")

FolderName = ws01.Range("C1") '保存されている保存先（フォルダー）

lRow = ws01.Cells(Rows.Count, "B").End(xlUp).Row 'B列の最終行を取得

For I = 4 To lRow '最終行まで繰り返す

OldFile = FolderName & "\" & ws01.Cells(I, "B")
NewFile = FolderName & "\" & ws01.Cells(I, "C")

OldFile_Kakucyoshi = Right(ws01.Cells(I, "B"), Len(ws01.Cells(I, "B")) - (Application.WorksheetFunction.Find(".", ws01.Cells(I, "B")) - 1))
NewFile_Kakucyoshi = OldFile_Kakucyoshi

NewFile = NewFile & NewFile_Kakucyoshi

Name OldFile As NewFile 'ファイル名を変更します。

Next I

End Sub

回答No.5

kkkkkm · ベストアンサー

> つまりFor文の2回めでエラーが出ているようです。

Set ObjFileSys = Nothingの場所が違いますね。
ObjFileSysを開放したのにObjFileSysを使ったからです。

Set ObjFileSys = Nothing
Next I

End Sub

は

Next I
Set ObjFileSys = Nothing
End Sub

お礼

ありがとうございます。

>Set ObjFileSys = Nothingの場所が違いますね。

　　コードを修正して上手くファイル名の変更が完了しました。

機能的には、問題ないのですが
　　旧ファイルが存在しない場合や
　　　新ファイルが既に存在する場合にエラー処理を追加したいのですが　？

　　何か良き方法がありますか　？

回答No.8

kkkkkm

> 　set XXで宣言したら、使用しなくなったらNotingで開放すべきとの認識ですか？

「べき」ではなくて、した方がいいんじゃないかなぁという程度です。
最後でもNothingがない時に連続で実行した場合、なんか動作が遅いなぁという事もありましたし、途中で必要なNothingを入れてない人のコード(複雑なコード)で動作がおかしくて、原因がわかるのに時間がかかったこともあります。

ので、Nothingは忘れない限り入れるようにしてます。無いと場合や場所によっては不具合がある可能性があり、あって不具合の可能性が無いのであればあったほうがいいということでしょうか。

Rangeの.Valueなんかもそうです。

お礼

>Nothingは忘れない限り入れるようにしてます。
>無いと場合や場所によっては不具合がある可能性があり、あって不具合の可能性が無いのであればあったほうがいいということでしょうか。

了解しました。

私も、忘れない限りは、
　Nothingで開放するようにしたいと思います。

今回もお世話になり、ありがとうございます。

回答No.7

kkkkkm

> 　何かアドバイスあればお願いします。

アドバイスという事もありませんが、とりあえず気が付いたことは
変数宣言が一部ないみたいです。
"B4:C40"の範囲だけのクリアでいいのでしょうか
たとえば、前回42行まであって、今回データが40行分だった場合、名前変更のコードで42行まで実行されてエラーになると思います。

また、
Set XX=*********
したものは
利用しなくなった時点(ループなどで再Setしないのであればコードの最後で)
Set XX = Nothing
した方がいいような気もします。(しなくてもいいという意見もあります)
以上です。

補足

アドバイスありがとうございます。

>利用しなくなった時点(ループなどで再Setしないのであればコードの最後で)
>Set XX = Nothing
＞した方がいいような気もします。(しなくてもいいという意見もあります)

私の場合、
　コードは、ネットで見つけたものを改造することが多いです。

kkkkkmさんは、
　set XXで宣言したら、使用しなくなったらNotingで開放すべきとの認識ですか？

私に認識ではマクロを起動して正常終了した時点で、
　setされた宣言は、自動的に開放されると「何となく」思っていたのですが
　nothingで開放しないと不具合が起こる可能性が有るのでしょうか　？

以下の、”「Set a = Nothing」のお話”
　で何となく解説は理解できますがやはり疑問は残ります。
https://www.moug.net/tech/exvba/0150027.html

----------------------------
>"B4:C40"の範囲だけのクリアでいいのでしょうか

心配されたように40行で決め打ちするのは、良くないですね。
使用されている列数をサーチして消込するように変更します。

回答No.6

kkkkkm

> 旧ファイルが存在しない場合や
> 　　　新ファイルが既に存在する場合にエラー処理を追加したいのですが　？

ブックを開く
http://officetanaka.net/excel/vba/file/file01.htm
上記サイトの
2.ファイルの存在を調べる

を参考にしてください。

補足

> 旧ファイルが存在しない場合や
> 　　　新ファイルが既に存在する場合にエラー処理を追加したいのですが　？

If文でファイル名の比較（存在）を考えましたが、
旧ファイル名の抜き出し処理の自動化を追加することに変更しました。
（これでエラー処理が必要なくなると思いました。）

以下追加コードを含めた、完成形ですが
　何かアドバイスあればお願いします。

Sub 旧ファイル名抜き出し()

Dim ws01 As Worksheet
Dim i As Integer
Dim DataFolder As String
Dim FileName As String

'指定フォルダー選択
Application.FileDialog(msoFileDialogFolderPicker).Show
Target = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

Set ws01 = Worksheets("ReName")

ws01.Range("C1") = Target

Set FS = CreateObject("Scripting.FileSystemObject")
Set Fol = FS.GetFolder(Target)
Set Fil = Fol.Files

'旧ファイル名レンジ及び新ファイル名レンジの事前にクリアー
ws01.Range("B4:C40").Clear

i = 4
For Each Fx In Fil
'ファイル名
sFile = Fx.Name
'ファイル名の書き出し
ws01.Cells(i, "B") = sFile
i = i + 1
Next

'旧ファイル名の一番長いセルのセル幅に自動調整
ws01.Range("B4").EntireColumn.AutoFit

End Sub

Sub 新ファイル名へ変更() '指定したファイル名に変更します。

Dim ws01 As Worksheet
Dim IRow, i As Single
Dim FolderName, OldFile, NewFile As String
Dim ObjFileSys As Object
Dim ExtensionName As String

Set ws01 = Worksheets("ReName")

'ファイルシステムを扱うオブジェクトを作成
Set ObjFileSys = CreateObject("Scripting.FileSystemObject")

FolderName = ws01.Range("C1") '保存されている保存先（フォルダー）

IRow = ws01.Cells(Rows.Count, "B").End(xlUp).Row 'B列の最終行を取得

For i = 4 To IRow '最終行まで繰り返す

OldFile = FolderName & "\" & ws01.Cells(i, "B")
NewFile = FolderName & "\" & ws01.Cells(i, "C")

'拡張子無しのファイル名を取得
ExtensionName = ObjFileSys.GetExtensionName(OldFile)

NewFile = NewFile & "." & ExtensionName

Name OldFile As NewFile 'ファイル名を変更します。

Next i

Set ObjFileSys = Nothing

'新ファイル名の一番長いセルのセル幅に自動調整
ws01.Range("C4").EntireColumn.AutoFit

MsgBox ("ファイル名の変更処理が終了しました")

End Sub

回答No.4

kkkkkm

> 以下が、参考画像です。

ファイルが見つからないという事ですから、パスが間違っているかファイル名が間違っているという事だと思います。TestじゃなくてTessなんでしょうか。

補足

>TestじゃなくてTessなんでしょうか。

適当にテスト用に作成したフォルダー名なので
　TESTが妥当な名称でしょうが、タイピングのミスでTessになりました。

その後、
　コードを見直していたところ、違うところでエラーが出ました。

ExtensionName = ObjFileSys.GetExtensionName(OldFile)
　　（オブゼクト変数またはWithブロック変数が設定されていません。）

この場合、
テスト用の4つのファイルの内、最初のファイルのみ上手くファイル名が変更されていました。
　　　　エピソード 1.mp4　に変名されています。

つまりFor文の2回めでエラーが出ているようです。

回答No.3

kkkkkm

> Name OldFile As NewFile
> でエラーが出てしまいます。

問題なく処理できますよ。セルのデータで￥が最後にあるとかフォルダが違うとかはないでしょうか

Debug.Print NewFile

で確認してみてください

補足

Debug.Print NewFile

このコマンドを利用したことが無いので
　　MSGBOX　を利用した時の加工画像を添付します。

NewFile = NewFile & "." & ExtensionName
　の後に
MsgBox NewFile

以下が、参考画像です。

　　　https://imgur.com/LudItSc

---------------
一部、個人情報なので黒消し処理しています。

回答No.2

kkkkkm

No1の補足です。

Scripting.FileSystemObject
を使わない場合は
Right(Filename, InStr(StrReverse(Filename), ".") - 1)
で取り出せると思いますが、システム利用したほうが間違いが無いと思います。

お礼

>システム利用したほうが間違いが無いと思います。

せっかく覚えた拡張子だけを取り出すコードえお利用しない手は無いので
試行錯誤していますがエラーから脱却出来ません。

VBAのDeBagで
　　ExtensionName = ObjFileSys.GetExtensionName(OldFile)
で拡張子のMP4が上手く取り出せて
次の
　　NewFile = NewFile & "." & ExtensionName
でファイル名と拡張子が結合されて、フルパスのファイル名.拡張子に成っているのに
　　変名を行う
　　　　Name OldFile As NewFile
でエラーが出てしまいます。

---------------------
Sub FilenameChange01() '指定したファイル名を変更します。

Dim ws01 As Worksheet
Dim IRow, I As Single
Dim FolderName, OldFile, NewFile As String
Dim ObjFileSys As Object
Dim ExtensionName As String

Set ws01 = Worksheets("ReName")

'ファイルシステムを扱うオブジェクトを作成
Set ObjFileSys = CreateObject("Scripting.FileSystemObject")

FolderName = ws01.Range("C1") '保存されている保存先（フォルダー）

IRow = ws01.Cells(Rows.Count, "B").End(xlUp).Row 'B列の最終行を取得

For I = 4 To IRow '最終行まで繰り返す

OldFile = FolderName & "\" & ws01.Cells(I, "B")
NewFile = FolderName & "\" & ws01.Cells(I, "C")

'拡張子無しのファイル名を取得
ExtensionName = ObjFileSys.GetExtensionName(OldFile)

NewFile = NewFile & "." & ExtensionName

Name OldFile As NewFile 'ファイル名を変更します。

Set ObjFileSys = Nothing
Next I

End Sub

回答No.1

kkkkkm

こちらを参考にしてください。

VBA ファイル名の取得または変更する
https://www.tipsfound.com/vba/18011

参照設定しない場合には

Dim fso As FileSystemObject
Set fso = New FileSystemObject '

を

Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

に変更してください。

お礼

Sub FilenameChange01() '指定したファイル名を変更します。

Dim ws01 As Worksheet
Dim lRow, I As Single
Dim FolderName, OldFile, NewFile As String
Dim ObjFileSys As Object
Dim ExtensionName As String

Set ws01 = Worksheets("ReName")

'ファイルシステムを扱うオブジェクトを作成
Set ObjFileSys = CreateObject("Scripting.FileSystemObject")

FolderName = ws01.Range("C1") '保存されている保存先（フォルダー）

lRow = ws01.Cells(Rows.Count, "B").End(xlUp).Row 'B列の最終行を取得

For I = 4 To lRow '最終行まで繰り返す

OldFile = FolderName & "\" & ws01.Cells(I, "B")
NewFile = FolderName & "\" & ws01.Cells(I, "C")

'拡張子無しのファイル名を取得
ExtensionName = ObjFileSys.GetExtensionName(OldFile)

NewFile = NewFile & "." & ExtensionName

Name OldFile As NewFile 'ファイル名を変更します。

Set ObjFileSys = Nothing
Next I

End Sub

補足

コピペのミスで改造コードのみがUPされてしまいました。

以下補足です。
--------------------------------------------------------
毎回、アドバイスありがとうございます。

拡張子(EXTENTION)のみを取り出すコードが有ることが判ったので
　下記のように改造しましたが、以下でエラーが出ます。

　　　ExtensionName = ObjFileSys.GetExtensionName(OldFile)