How to rename filename base on filename contains

I have folder “A”. In this folder I have 12 excel file with only one sheet i.e. “Sheet1”.
Excel file name is like 01_ABCD_C01 April, 01_ABCD_C01 May ………01_ABCD_C01 December etc.
Here C01 is vendor ID
I am extracting “Sheet1” of every excel file in one WorkBook and change sheet1 name base on cell value F6 and save file in C folder.
I am doing this task for every vendor. I am using following code for this.
Now my question is : when I save excel file in C folder then the name of extracted file is base (01_ABCD_C01 April) on client id. The every excel file name contains C01 is a client ID.

Sub ImportFiles()
Dim wbOpen As Workbook
Dim wbNew As Workbook
Dim fName As String
'Change Path
Const strPath As String = "C:\Users\s\Desktop\A\"
Dim strExtension As String
MsgBox ("Do you Want to Extract Files?")
'Comment out the 3 lines below to debug
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
ChDir strPath
'Change extension
strExtension = Dir("*.xls")
Set wbNew = Workbooks.Add
'Change Path, Name and File Format
wbNew.SaveAs Filename:="C:\Users\s\Desktop\C\Consolidation", FileFormat:=xlWorkbookNormal
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension)
With wbOpen
.Sheets("Sheet1").Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
ActiveSheet.Name = ActiveSheet.Range("F6")
wbNew.Sheets(wbNew.Sheets.Count).Name = wbNew.Sheets(wbNew.Sheets.Count).Cells(1, 1)
.Close SaveChanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
MsgBox ("Files Extracted Succussfully")
fName = Dir("C:\Users\s\Desktop\A\*.*")
Do While fName <> ""
If fName <> "Master1.xls" And fName <> "Master2.xls" Then 'or .txt or .csv or whatever
Kill "C:\Users\s\Desktop\A\" & fName
End If
fName = Dir
Loop
End Sub