【VBA】指定したフォルダのファイル一覧を取得、名前を一括で変更する方法

Sub ファイル一覧()
Dim buf As String
Dim i As Long
Dim Path As String
 
'フォルダの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    Path = .SelectedItems(1)
    End With
 
'エクセルのみ抽出
    buf = Dir(Path & "\*.xlsx")
    
    Cells(2, 3).Value = "フォルダ⇒"
    Cells(2, 4).Value = "=HYPERLINK(""" & Path & """,""リンク"")"
    Cells(2, 5) = Path
     
     
'CELL B2からスタート。
     
     
   Cells(4, 2) = "No"
   Cells(4, 3) = "ファイル名"
   Cells(4, 4) = "リンク"
   Cells(4, 5) = "パス"
   Cells(4, 6) = "名前を変更したい場合↓"
      
     i = 4
     
    Do While buf <> ""
        i = i + 1
'No
        Cells(i, 2) = i - 4
'ファイル名
        Cells(i, 3) = buf
'リンクを
        LINK = Path & "\" & buf
        Cells(i, 4).Value = "=HYPERLINK(""" & LINK & """,""リンク"")"
        Cells(i, 5).Value = LINK
 
        buf = Dir()
    Loop
    
    Columns(5).ShrinkToFit = True

    
 
End Sub

Sub ファイル名前変更()
Dim buf As String
Dim i As Long
Dim Path As String
 
'フォルダの選択
    Path = Cells(2, 5)
    
    LASTY = Cells(Rows.Count, 3).End(xlUp).Row

    For i = 5 To LASTY
    
        If Cells(i, 6) <> "" Then
        
            OldName = Path & "\" & Cells(i, 3)

            '拡張子有り無しで分岐
            If InStr(1, Cells(i, 6), ".") > 0 Then
            
                NewName = Path & "\" & Cells(i, 6)
            
            Else
            
                KAKUCHOUSHI = Mid(Cells(i, 3), InStr(1, Cells(i, 3), "."))
                NewName = Path & "\" & Cells(i, 6) & KAKUCHOUSHI
            
            End If
        
            '名前の変更
            Name OldName As NewName
            Cells(i, 7) = "完了"
        
        End If
    
    Next
 
End Sub