Excel Event to Open and change file name

[12Rev79]

Greetings Experts,

I need your kind help, I have an Excel "Extract.xlsx" with a list of my Workbooks like below
Column D

Ref Fabrication

DIV-CEGS-XS-AF-1370

DIV-CEGS-XS-AF-1385

DIV-CEGS-XS-AF-1386

MIV-SEGS-PS-GF-1392

DIV-CEGS-XS-AF-1396

And I want that when I click my button "cmdGenerate" it will it will Open the other Excel file "Key support_DIV-CEGS-XS-AF-Fabrication.xlsx"
then Save As a new file name like "Key support_DIV-CEGS-XS-AF-1370.xlsx" and so on.
Then change the Cell A5 Value to CEGS-XS-AF-1370 Save and Close.
Note :
-It will be Save As in the same folder "C:\Desktop\Fabrication"
-The code will stop until the last row in Column D.

May be someone is kind to help me to figure out the code.

Thanks in advance appreciated.
12Rev79

 

[SunnyAlv]

like this ?

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

 

[12Rev79]

like this ?

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

View attachment 120398

Hi SunnyAlv,
The code works appreciate your hep but please help I want to include in Cell A5 "DIV-" like below
DIV-CEGS-XS-AF-1370
DIV-CEGS-XS-AF-1385

and how to modify the code below that I want every Save As copy the Value in Cell A5 should be like below
File Name Value in Cell A5
Key support_DIV-CEGS-XS-AF-1370 DIV-CEGS-XS-AF-1370
Key support_DIV-CEGS-XS-AF-1385 DIV-CEGS-XS-AF-1385

.Range("A5").Value = Mid(ws.Range("D2").Value, 5, 20) 'Change the Cell A5 Value to CEGS-XS-AF-1370 and so on

Thanks again and appreciated your help.