Sub RenameAllExcelFilesInDirectory()
Dim iReply As String ''' Added
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
filepath = .SelectedItems(1)
End With

Set r = Workbooks.Add.Worksheets(1).Range("A1")
StrFile = Dir(filepath & "\*.*")

Do While Len(StrFile) > 0
strExtension = Split(StrFile, ".")(UBound(Split(StrFile, ".")))

Set wb = Workbooks.Open(filepath & "\" & StrFile)
StrNewfullfilename = ThisWorkbook.Sheets(1).Range("B1").Value & "." & strExtension''' added this workbook name not sure if this is what u wanted
wb.Close

r.Value = StrFile 'print old name
r.Offset(, 1).Value = StrNewfullfilename 'print new name
Set r = r.Offset(1)
Name filepath & "\" & StrFile As filepath & "\" & StrNewfullfilename
StrFile = Dir
iReply = InputBox(Prompt:="Please Enter Next File", _
            Title:="Update File")
    If iReply = "" Then Exit Sub
    ThisWorkbook.Sheets(1).Range("B1").Value = iReply
Loop

End Sub