VBA Open and Save As new name from Listed to another workbook

[12Rev79]

Hi Experts,

Please I need your help for me to figure out of how to modify the code below.
The code execution, Open my file "Key support_DIV-CEGS-XS-AF-Fabrication.xlsx" then Save As with new name that are list in my "Extract.xlsx" in Column D, like;

Column D:
Ref Voucher
DIV-CEGS-XS-AF-1370
DIV-CEGS-XS-AF-1385

I want the code to open my file "Key support_DIV-CEGS-XS-AF-Fabrication.xlsx" Save As with the New name like
"Key support_DIV-CEGS-XS-AF-1370.xlsx" and change the value of Cell A5 "DIV-CEGS-XS-AF-1370" then save and close then go to next cell
"Key support_DIV-CEGS-XS-AF-1385.xlsx" and change the value of Cell A5 "DIV-CEGS-XS-AF-1385"
the code will stop up to the last value that is listed in my Column D.

VBA Code:
Sub Macro1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim ws As Worksheet, KeyW As Workbook, KeyS As Worksheet, ls As Long, i As Integer
Dim path As String, keypath As String

path = "C:\Desktop\Fabrication" 'Link Folder data
keypath = "Key support_DIV-CEGS-XS-AF-Fabrication.xlsx"

Set ws = ThisWorkbook.Sheets(1) 'Set ur Sheet Name in "Extract.xlsx"
ls = ws.Cells(Rows.Count, "D").End(xlUp).Row

Set KeyW = Workbooks.Open(path & "\" & keypath) 'Open file "Key support_DIV-CEGS-XS-AF-Fabrication.xlsx"
Set KeyS = KeyW.Sheets(1) 'Set ur Sheet Name in "Key support_DIV-CEGS-XS-AF-Fabrication.xlsx"

For i = 2 To Application.CountA(ws.Range("D2:D" & ls))+1
With KeyS
.Range("A5").Value = Mid(ws.Range("D2").Value, 5, 20) 'Change the Cell A5 Value to CEGS-XS-AF-1370 and so on
KeyW.SaveCopyAs path & "\" & "Key support_" & ws.Range("D" & i).Value & ".xlsx" 'Save As a new file name like "Key support_DIV-CEGS-XS-AF-1370.xlsx" and so on.
End With
Next i
KeyW.Close False 'Close file "Key support_DIV-CEGS-XS-AF-Fabrication.xlsx"
MsgBox "Done"
End Sub


Thanks in advance for the help
12Rev79