Create Copies of Workbook with Sheet2 Formulas Referencing Sheet1 Not Workbook Copied

[BigDawg15]

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

[p45cal]

Copy both sheets at the same time. Try changing:

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)

to:

For Each c In rng
  Sheets(Array("Sheet1", "Sheet2")).Copy
  Set wb = ActiveWorkbook
  'wb.Sheets(1).Range("A1") = c.Value
  wb.Sheets(1).Range("I19") = c.Value

I haven't used your object variasble sh2, but looking into a more robust solution.

later edit:
I'm getting nowhere creating a collection of sheets to copy at once using object variables, so if I don't find anything better you could use the likes of:

 Sheets(Array("Sheet1", sh2.name)).Copy

[Dave]

Using a collection to copy the sheets may help. Here's the general outline...

Dim FSO As Object, FilDir As Object, ShtCollect As Collection
Dim sht As Worksheet, cnt As Integer
Set FSO = CreateObject("Scripting.FilesystemObject")
Set FilDir = FSO.getfile("C:\yourfoldername\filename.xlsm")
Workbooks.Open Filename:=FilDir
'load sheets in collection
Set ShtCollect = New Collection
For Each sht In Workbooks(FilDir.Name).Sheets
ShtCollect.Add Workbooks(FilDir.Name).Sheets(sht.Name)
Next sht
'copy collection sheets to wb
For cnt = 1 To ShtCollect.Count
ShtCollect(cnt).Copy ThisWorkbook.Sheets(cnt)
Next cnt
'close wb
Workbooks(FilDir.Name).Close SaveChanges:=False

HTH. Dave

[BigDawg15]

Dave, thank you for looking. P45, looks like your initial suggestion works. Thank you so much.

BigDawg15