BigDawg15
Board Regular
- Joined
- Apr 23, 2018
- Messages
- 72
- Office Version
- 365
- 2016
- Platform
- Windows
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.
Thank you in advance,
BigDawg15
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.
Code:
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 in advance,
BigDawg15