VBA to rename files and move them to a different folder

Another way

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 <> ""
        Name s & f As d & Replace(f, "Current Week", p)
        f = Dir
    Loop
End If

End Sub