VBA to rename files and move them to a different folder

Just add the highlighted text

Sub Test()
Dim p$, s$, d$

With Sheet1
    p = .[B1] & " " & .[B2]
    s = .[A7] & "\"
    d = .[A10] & "\"
End With

If Len(Dir(s)) And Len(Dir(d)) Then
    f = Dir(s & "*.xlsx")
    Do While f <> ""
       If InStr(f, "Current Week") Then Name s & f As d & Replace(f, "Current Week", p)
        f = Dir
    Loop
End If

End Sub