以下のようなファイル名の変更方法を教えてください。解決したら、解決に役立った回答者の方たちに、合計１５００～２０００ポイントを配分します。

Sub Macro1()

'

' Macro1 Macro

'

'

'A列 名前

'B列 種類 ← 以下を 実際に使用しているものに変更してください。

a1 = "MPGファイル"

b1 = ".mpg"

a2 = "テキストファイル"

b2 = ".txt"

'C列 変換後ファイル名

'D列 存在チェック

'

'実行する前に、このエクセルファイルを保存してください。

'保存しないと正しく実行されないと思われます。

'このエクセルファイルが、あるところに リネームしたいファイルを置いてください。

'念のため、バックアップを お願いします。

'

For A = 1 To 65536 Step 2

If Range("A" & A) = "" Then Exit For

f1 = ThisWorkbook.Path + "\" + Range("a" & A)

If Range("B" & A) = a1 Then f2 = b1

If Range("B" & A) = a2 Then f2 = b2

If Dir(f1 & f2) = "" Then

Range("C" & A) = "存在しません"

GoTo next1:

End If

Range("C" & A) = "存在します"

If Range("A" & (A + 1)) = "" Then Exit For

f3 = ThisWorkbook.Path + "\" + Range("a" & (A + 1))

If Range("B" & (A + 1)) = a1 Then f4 = b1

If Range("B" & (A + 1)) = a2 Then f4 = b2

If Dir(f3 & f4) = "" Then

Range("C" & (A + 1)) = "存在しません"

GoTo next1:

End If

Range("C" & (A + 1)) = "存在します"

g1 = ""

If f2 = b2 Then g1 = f1 & f2

If f4 = b2 Then g1 = f3 & f4

If g1 = "" Then GoTo next1:

d = FreeFile

Open g1 For Input As #d

Line Input #d, aaa

Line Input #d, aaa

Line Input #d, aaa

Line Input #d, aaa

Line Input #d, aaa '5行目

Close #d

Range("D" & A) = aaa & f2

Range("D" & (A + 1)) = aaa & f4

Name f1 & f2 As ThisWorkbook.Path + "\" + aaa & f2

Name f1 & f4 As ThisWorkbook.Path + "\" + aaa & f4

'

next1:

Next A

End Sub

１．更新日時順に並べ替えます

２．名前の部分を全部ドラッグして、右クリックで

　　名前の変更を選択し、一番上を「デザイナー密着４カ月」

　　に変えてEnterを押します。

３．デザイナー密着４カ月（１）

　　デザイナー密着４カ月（２）

　　デザイナー密着４カ月（３）　と全てのﾌｧｲﾙ名が替わり

　　連番がつきます。

http://www.vector.co.jp/vpack/filearea/win/util/file/name/index_...

5行目が 何もない場合に対応です。

Range("D" & A) = aaa & f2

Range("D" & (A + 1)) = aaa & f4

Name f1 & f2 As ThisWorkbook.Path + "\" + aaa & f2

Name f1 & f4 As ThisWorkbook.Path + "\" + aaa & f4

の部分を

if trim(aaa)<>"" then

Range("D" & A) = aaa & f2

Range("D" & (A + 1)) = aaa & f4

Name f1 & f2 As ThisWorkbook.Path + "\" + aaa & f2

Name f1 & f4 As ThisWorkbook.Path + "\" + aaa & f4

end if

とすればいいでしょう。

既に解決されているようなので、投稿しようか迷いましたが、一応、別の方法（VBScript）ということで投稿します（せっかく作ったので・・・）

プログラムの概要としましては、

1. 指定したフォルダの *.txt を検索
2. テキストファイル内の「番組名」を取得
3. RENAME コマンドを画面（コンソール）に出力
　例）
　RENAME "仕事プロフェッショナル 06-05.mpg" "「デザイナー密着４カ月」.mpg"
　RENAME "仕事プロフェッショナル 06-05.txt" "「デザイナー密着４カ月」.txt"
　
　＜番組名が空白だった場合、以下のコメント行を出力します＞
　REM [xxxxxxxxxxxxxxxxxxx.txt] の番組名が正しく設定されていません。
4. 「1.」を繰り返す

という感じです。

プログラムは、「仕事プロフェッショナル??-??」の txt があるフォルダに

「MakeRenameCmd.vbs」という名前をつけて保存してください。

実行は、コマンドプロンプト（「ファイル名を指定して実行」にて「cmd」を実行）より

CScript MakeRenameCmd.vbs //Nologo > AllRename.cmd

とすると、リネーム用のバッチファイル「AllRename.cmd」が生成されます。

このバッチファイル実行すると、ファイル名のリネーム処理を一括で行います。

（処理を行う場合は、必ずバックアップをとって置いてから行ってください。）

' File : MakeRenameCmd.vbs
' Usage : CScript MakeRenameCmd.vbs //Nologo > AllRename.cmd
'
Option Explicit

' 仕事プロフェッショナル??-?? の txt があるフォルダを指定します
Const g_strTargetFolder = "C:\home\edu\hatena\kenpo43\1184565843\Data"
' 番組名の入っているファイルの拡張子を指定します
Const g_strTargetExt = "txt"

Const ForReading = 1

Dim g_fso ' FileSystemObject 用のグローバル変数

Call Main

Sub Main
    Set g_fso = CreateObject("Scripting.FileSystemObject")
    
    Call MakeRenameCmd
    
    Set g_fso = Nothing
End Sub

Sub MakeRenameCmd
    Dim folder
    Set folder = g_fso.GetFolder( g_strTargetFolder )
    
    Dim strBaseName    ' オリジナルのファイル名
    strBaseName = ""
    
    Dim strProgramName ' 番組名
    strProgramName = ""
    
    Dim file
    For Each file In folder.Files
        If g_strTargetExt = g_fso.GetExtensionName(file.Path) Then
            ' ＜ファイル名から拡張子を取り除く＞
            ' [仕事プロフェッショナル 06-05.txt] → [仕事プロフェッショナル 06-05]
            strBaseName = g_fso.GetBaseName( file.Path )
            
            ' ＜テキストファイルから番組名を取得＞
            ' [「デザイナー密着４カ月」]
            strProgramName = GetProgramNameFromTextFile( file.Path ) 
            
            If Len(strProgramName) > 0 Then
                ' ＜*.mpg のリネームコマンドを生成＞
                ' [RENAME "仕事プロフェッショナル 06-05.mpg" "「デザイナー密着４カ月」.mpg"]
                WScript.Echo "RENAME """ & strBaseName & ".mpg"" """ & strProgramName & ".mpg"""
                
                ' ＜*.txt のリネームコマンドを生成＞
                ' [RENAME "仕事プロフェッショナル 06-05.txt" "「デザイナー密着４カ月」.txt"]
                WScript.Echo "RENAME """ & strBaseName & ".txt"" """ & strProgramName & ".txt"""
            Else
                WScript.Echo "REM [" & file.Path & "] の番組名が正しく設定されていません。"
            End If
        End If
    Next
    
    Set folder = Nothing
End Sub

' テキストファイルから番組名を取得する関数
Function GetProgramNameFromTextFile( strFileName )
    Dim file
    Set file = g_fso.OpenTextFile( strFileName, ForReading)

    Dim nLine
    nLine = 5 ' 取得するデータ（番組名）がある行数
    
    Dim i
    For i = 1 To nLine - 1
        file.ReadLine       ' １～（Ｎ-１）行を読み飛ばす
    Next
    
    Dim strLine
    strLine = file.ReadLine ' Ｎ行目のデータを取得する
    strLine = Trim(strLine) ' 前後の空白除去
    file.Close
    Set file = Nothing
    
    GetProgramNameFromTextFile = strLine
End Function