VBA to rename files and move them to a different folder

On my computer I have a source folder:
C:\Users\jonat\Documents\Finance

And also a folder for a weekly archiving process.
C:\Users\jonat\Documents\Archive

In the source folder I have my weekly files. I am using 5 for this example, but in reality I have far more.
Taunton - Current Week.xlsx
Newbury - Current Week.xlsx
Exeter - Current Week.xlsx
Plymouth - Current Week.xlsx
Bristol - Current week.xlsx

I am hoping someone can provide some vba code which will:-
Rename all the files in the source folder, replacing Current Week with the Period in cell B1 and the Week in cell B2.
And move the renamed files from the source folder to the archive folder.

So for example.
Before vba is run.
Taunton - Current Week.xlsx starts in source folder.
After vba is run
We have Taunton - P13 W1.xlsx in archive folder.

I change the variables in cell B1 and B2 each week.

Try it

Sub demo()
Const source_folder = "C:\Users\jonat\Documents\Finanse"
Const archive_folder = "C:\Users\jonat\Documents\Archive"
Dim destfile As String, B1B2 As String, fso As Object, folder As Object, f As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(source_folder) And fso.FolderExists(archive_folder) Then
        With Worksheets("Sheet1")
            B1B2 = .Range("B1").Value & " " & .Range("B2").Value
        End With
        Set folder = fso.GetFolder(source_folder)
        For Each f In folder.files
            destfile = Replace(f.Name, "Current Week", B1B2, , , vbTextCompare)
            fso.MoveFile f.Path, archive_folder & "\" & destfile
        Next f
    End If
    Set fso = Nothing
End Sub

I've closed the post as solved, but had one question if you don't mind.
I have one or two admin files in my source folder, so could you provide an extra code on the f.Name part, so it only does the rename and move if the file contains "Current Week" somewhere in the name.

Many thanks for this extra question.

Originally Posted by picton2000

I've closed the post as solved, but had one question if you don't mind.
I have one or two admin files in my source folder, so could you provide an extra code on the f.Name part, so it only does the rename and move if the file contains "Current Week" somewhere in the name.

Many thanks for this extra question.

I added red

Sub demo()
Const source_folder = "C:\Users\jonat\Documents\Finanse"
Const archive_folder = "C:\Users\jonat\Documents\Archive"
Dim destfile As String, B1B2 As String, fso As Object, folder As Object, f As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(source_folder) And fso.FolderExists(archive_folder) Then
        With Worksheets("Sheet1")
            B1B2 = .Range("B1").Value & " " & .Range("B2").Value
        End With
        Set folder = fso.GetFolder(source_folder)
        For Each f In folder.files
            destfile = Replace(f.Name, "Current Week", B1B2, , , vbTextCompare)
            If destfile <> f.Name Then fso.MoveFile f.Path, archive_folder & "\" & destfile
        Next f
    End If
    Set fso = Nothing
End Sub

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

Thank you to the two replies, excellent work.

Originally Posted by picton2000

Thank you to the two replies, excellent work.

For clarity I mention that you are English and for you it makes no difference. But someone not English can have an alphabet that contains unicode, and he has a path that contains unicode, he can't use the code from DIR. Because DIR doesn't support unicode. My code is written for a wider range of users.

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