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