VBA code does not copy to new workbooks

[GARTHMAN]

Suggestions please... the following code runs successfully as far as creating daily spreadsheets for the year, but the vba codes or macros fail to copy to the new workbooks. In addition to this macro, there are two others that are not showing up in the new files. Thanks in advance for your insight.

Option Explicit

Sub Create_Multiple_Workbooks()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.StatusBar = False
'
Dim i As Long
Dim wb As Workbook
Dim fec1 As Date, fec2 As Date
Dim l1 As Workbook, h1 As Worksheet
Dim ruta As String, mes As String, ruta2 As String, arch As String
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("Ops-Fleetwatch-GFI Comparison") 'name of template sheet
'
ruta = l1.Path & "\"
fec1 = DateSerial(2021, 7, 1) 'YYYY, M, D'
fec2 = DateSerial(2022,6, 30) 'YYYY, M, D'
For i = fec1 To fec2
Application.StatusBar = "Creating file : " & i
mes = Format(i, "MMM")
If Dir(ruta & mes & "\") = "" Then
MkDir (ruta & mes)
End If
ruta2 = ruta & mes & "\"
arch = "Operations-Fleetwatch-GFI Daily Vehicle Log " & Format(i, "MM-DD-YYYY")

ActiveWorkbook.Sheets.Copy
[b4] = Format(i, "DDDD, mm/dd/yyyy 04:00:00")
[e4] = Format((i + 1), "DDDD, mm/dd/yyyy 03:59:59")
Set wb = ActiveWorkbook
Range("E4").NumberFormat = "dd-mm-yyy"
wb.SaveAs Filename:=ruta2 & arch & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled
wb.Close False
Next
Application.StatusBar = False
MsgBox "End"

End Sub

 

[Joe4]

Instead of using this line:

ActiveWorkbook.Sheets.Copy

to create a new workbook, and saving that, why not just remove that and save the current file with a "SaveAs" command?
That will save the existing workbook under a new name, which will keep all the VBA code.

 

[GARTHMAN]

Thanks for a quick reply. Removing the line does allow the macros to carry over to the next workbook. However, it hangs up after the 1st one is created and will not continue through the specified date range as it did with the code included. Not sure why. It makes sense to me looking at it, but something is missing that is preventing the progression. I appreciate any additional insights you can provide.

Option Explicit

Sub Create_Multiple_Workbooks()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.StatusBar = False
'
Dim i As Long
Dim wb As Workbook
Dim fec1 As Date, fec2 As Date
Dim l1 As Workbook, h1 As Worksheet
Dim ruta As String, mes As String, ruta2 As String, arch As String
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("Ops-Fleetwatch-GFI Comparison") 'name of template sheet
'
ruta = l1.Path & "\"
fec1 = DateSerial(2021, 7, 13) 'YYYY, M, D'
fec2 = DateSerial(2021, 7, 31) 'YYYY, M, D'
For i = fec1 To fec2
Application.StatusBar = "Creating file : " & i
mes = Format(i, "MMM")
If Dir(ruta & mes & "\") = "" Then
MkDir (ruta & mes)
End If
ruta2 = ruta & mes & "\"
arch = "Operations-Fleetwatch-GFI Daily Vehicle Log " & Format(i, "MM-DD-YYYY")

ActiveWorkbook.Sheets.Copy 'I removed this line'
[b4] = Format(i, "DDDD, mm/dd/yyyy 04:00:00")
[e4] = Format((i + 1), "DDDD, mm/dd/yyyy 03:59:59")
Set wb = ActiveWorkbook
Range("E4").NumberFormat = "dd-mm-yyy"
wb.SaveAs Filename:=ruta2 & arch & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled
wb.Close False
Next
Application.StatusBar = False
MsgBox "End"

End Sub

 

[Joe4]

You will probably need to move this line out of your For...Next loop, and have it at the end of your code:

wb.Close False

Another, it will close it after the first one and never do the rest.

 

[GARTHMAN]

You will probably need to move this line out of your For...Next loop, and have it at the end of your code:

wb.Close False

Another, it will close it after the first one and never do the rest.

Thanks for the advice. I ended up removing that line completely and that leaves the last workbook created open. This allows me to verify that all created sheets look and function the way they should. Works like a charm! Thanks for your assistance. YOU da MAN!

 

[Joe4]

You are welcome.
Glad I was able to help.