The following code works to loop through names in Index worksheet and copy Sheet1 and Sheet2 to a new workbook named from Index list. Only problem I cannot decipher is it
is copying the formulas from Sheet2 in the original workbook and they remain linked to original workbook instead of to the workbook they are copied into. Any help is appreciated.

Also posted at: https://www.mrexcel.com/board/threads/create-copies-of-workbook-with-sheet2-formulas-referencing-sheet1-not-workbook-copied-from.1190466/


 
Sub SaveCopyofWorkbookEDITED()
Dim FilePath As String '
Dim FolderObj As Object '
Dim wb As Workbook, sh1 As Worksheet, lr As Long, rng As Range
 
On Error GoTo LeverageLean
 
Application.DisplayAlerts = False 'Hide Display Alerts
 
FilePath = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - Len(ActiveWorkbook.Name)) & Format(Date, "YYYY") 'Active Workbook File Path and Current Year Folder
 
Set FolderObj = CreateObject("Scripting.FileSystemObject")
If FolderObj.FolderExists(FilePath) Then 'The Folder has been found
Else: FolderObj.CreateFolder (FilePath) 'The Folder has been created
End If
 
FilePath = FilePath & "\" & Format(Date, "MMMM") 'File Path and Current Month Folder
 
Set FolderObj = CreateObject("Scripting.FileSystemObject")
If FolderObj.FolderExists(FilePath) Then 'The Folder has been found
Else: FolderObj.CreateFolder (FilePath) 'The Folder has been created
End If

Set sh1 = Sheets("Index") 'Edit sheet name
Set sh2 = Sheets("Sheet2") 'Edit sheet name
lr = sh1.Cells(Rows.Count, "A").End(xlUp).Row
Set rng = sh1.Range("A1:A" & lr)
 
 
For Each c In rng
   Sheets("Sheet1").Copy 'Edit sheet name
   Set wb = ActiveWorkbook
  'wb.Sheets(1).Range("A1") = c.Value
   wb.Sheets(1).Range("I19") = c.Value
   sh2.Copy After:=wb.Sheets(1)
 
 
'Application.ActiveWorkbook.SaveAs Filename:=FilePath & "\" & Format(Date, "MM.DD.YYYY") & "_" & Format(Now, "HH.MM") & Right(ActiveWorkbook.FullName, (Len(ActiveWorkbook.FullName) + 1) - InStrRev(ActiveWorkbook.FullName, ".")) 'Save copy to Active Workbook File Path\Current Year\Current Month\Current Date & Time
 Application.ActiveWorkbook.SaveAs Filename:=FilePath & "\" & Format(Date, "MM.DD.YYYY") & Right(ActiveWorkbook.FullName, (Len(ActiveWorkbook.FullName) + 1) - InStrRev(ActiveWorkbook.FullName, ".")) & c.Value & ".xlsx"  'Save copy to Active Workbook File Path\Current Year\Current Month\Current Date & Time

'MsgBox "A copy of this Active Workbook named """ & Format(Date, "MM.DD.YYYY") & Right(ActiveWorkbook.FullName, (Len(ActiveWorkbook.FullName) + 1) - InStrRev(ActiveWorkbook.FullName, ".")) & """ has been saved to the following location:" & vbNewLine & vbNewLine & Left(FilePath, InStr(1, ActiveWorkbook.FullName, ActiveWorkbook.Name) - 1)
 
 Next
Exit Sub
  wb.Close True
 
LeverageLean:
MsgBox (Err.Number & " - " & Err.Description & vbNewLine & vbNewLine & "Don't hesitate to email me: anyone@test.com")
 
End Sub
Thank you,

BigDawg15