Excel VBA: rename files v2

Hello experts,

I have the following procedure to rename files.

Sub Rename_Files()
Dim xDir As String
Dim xFile As String
Dim xRow As Long
Dim Ans As VbMsgBoxResult

Ans = MsgBox("Before running this procedure, please check that old_files_names are reported in column A and new_files_names are reported in column B." & _
vbNewLine & "If so, please click on Yes else click on No and run List Files procedure in order to get files to rename.", vbQuestion + vbYesNo, "Confirm Please!")
If Ans = vbNo Then Exit Sub

With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    If .Show = -1 Then
        xDir = .SelectedItems(1)
        xFile = Dir(xDir & Application.PathSeparator & "*")
        Do Until xFile = ""
            xRow = 0
            On Error Resume Next
            xRow = Application.Match(xFile, Range("A:A"), 0)
            If xRow > 0 Then
                Name xDir & Application.PathSeparator & xFile As _
                xDir & Application.PathSeparator & Cells(xRow, "B").Value
            End If
            xFile = Dir
        Loop
    End If
End With
End Sub

Select allOpen in new window

I would like to add the following requirement:
Perform the rename in a new folder located in the same folder in which are located files:
Name of the folder: Rename- & Format(Now, "yyyy-mm-dd-hh-mm")

Thank you very much for your help.