前回に続き、今回は標準モジュールにメインの動作をコーディングしていきます。

VBAのプロジェクトツリーを右クリック→挿入から標準モジュールを追加します。

１．Cell_cls
実行するとセル中のファイル名、フォルダ名をクリアするコードを描いていきます。

Sub Cell_cls()
' delete Macro'
    '4行目以降を全削除する'
    Range("A4:G4").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

    Selection.ClearContents

　　'A4セルを選択して完了'
    Range("A4").Select
    
End Sub

２．make_list
ファイル名と拡張子をそれぞれ、A列、B列に書き出すプログラム

Sub make_list()

'FSOを使うため、参照設定からMicrosoft Scripting Runtime　をチェックしておくこと'

Dim fso As FileSystemObject
Set fso = New FileSystemObject

Dim fl As Folder
Set fl = fso.GetFolder(Sheet1.TextBox_path.Text)
Dim f As File
Application.ScreenUpdating = False

i = 4
For Each f In fl.Files ' フォルダ内のファイルを取得しながらループ'

'今回の例ではファイル名と拡張子を別々のセルに格納する'
Cells(i, 1).Value = fso.GetBaseName(f)
Cells(i, 2).Value = fso.GetExtensionName(f)

'変更後のファイル名にもとりあえず、現在のファイル名をコピペ'
Cells(i, 3).Value = Cells(i, 1).Value
Cells(i, 4).Value = Cells(i, 2).Value
i = i + 1

Next

' FSOオブジェクトの後始末'
Set fso = Nothing

Application.ScreenUpdating = True

End Sub

３．folder_list
フォルダ名をF列に書き出すプログラム
　make_listと概ね同じコード。Object.filesがObject.Subfoldersに変わるだけ

Sub folder_list()

Dim fso As FileSystemObject
Set fso = New FileSystemObject

Dim fl As Folder
Set fl = fso.GetFolder(Sheet1.TextBox_path.Text)

Dim f As Object

Application.ScreenUpdating = False

i = 4
For Each f In fl.SubFolders ' フォルダ内のサブフォルダを取得しながらループ'

Cells(i, 6).Value = fso.GetBaseName(f)
Cells(i, 7).Value = Cells(i, 6).Value

i = i + 1

Next

Set fso = Nothing

Application.ScreenUpdating = True

End Sub

４．change_fname
セル内の変更前後のファイル名を確認し、変更があれば、ファイル名の変更を実施するプログラム
Ucaseを使うことであえて大文字、小文字の違いは判定しないようにしています。

Sub change_fname()

Dim fso As FileSystemObject
Set fso = New FileSystemObject

Dim fl As Folder
Set fl = fso.GetFolder(Sheet1.TextBox_path.Text)

Dim f As File

i = 4
Do Until Cells(i, 1).Value = ""

'変更前ファイル名の指定（拡張子有無判定）'
    If Cells(i, 1).Value <> "" & Cells(i, 2).Value <> "" Then
        fn1 = fl & "\" & Cells(i, 1).Value & "." & Cells(i, 2).Value
        
    ElseIf Cells(i, 1).Value <> "" & Cells(i, 2).Value = "" Then
        fn1 = fl & "\" & Cells(i, 1).Value
    End If
    
'変更後ファイル名の定義'
    If Cells(i, 3).Value <> "" & Cells(i, 4).Value <> "" Then
        fn2 = Cells(i, 3).Value & "." & Cells(i, 4).Value
        
    ElseIf Cells(i, 3).Value <> "" & Cells(i, 4).Value = "" Then
        fn2 = Cells(i, 3).Value
    
    Else
        fn2 = ""
        
    End If
    
'変更後ファイル名fn2が空でなければファイル名変更を実施'
    If fn2 <> "" Then
        If UCase(fso.GetFile(fn1).Name) <> UCase(fn2) Then
        fso.GetFile(fn1).Name = fn2
        End If
    End If

i = i + 1
Loop

' 後始末'
Set fso = Nothing

End Sub

５．change_folder
change_fnameと同様。変更前後の名前が異なる場合フォルダ名を変更する

Sub change_folder()

Dim fso As FileSystemObject
Set fso = New FileSystemObject

Dim fl As Folder
Set fl = fso.GetFolder(Sheet1.TextBox_path.Text)

Dim f As File


i = 4
Do Until Cells(i, 6).Value = ""

'変更前フォルダ名の指定'
    If Cells(i, 6).Value <> "" Then
        fn1 = fl & "\" & Cells(i, 6).Value

    End If
    
'変更後フォルダ名の指定'
    If Cells(i, 7).Value <> "" Then
        fn2 = Cells(i, 7).Value
        
    Else
        fn2 = ""
        
    End If
    
'フォルダ名fn2が空でなければファイル名変更を実施'
    If fn2 <> "" Then
        If UCase(fso.GetFolder(fn1).Name) <> UCase(fn2) Then
        fso.GetFolder(fn1).Name = fn2
        End If
    End If
    

i = i + 1
Loop

' 後始末'
Set fso = Nothing


End Sub

コーディングは以上で終了です。
お疲れ様でした。

あとは使い勝手を良くするために、条件付き書式で変更前後の違いがあるセルだけ色付けしてみましょう。
これでファイルがたくさんあっても変更されるファイルがひと目でわかるようになりました。