VBA copy sheet to new workbook multiple time

[hajiali]

hello needing to copy sheet to a new workbook multiple times.

With each sheet in the new workbook the value in K1 is a date in "DDDD, MMMM DD, YYYY" Format needs to add 1. naming each sheet the K1 value in MM-DD format.
would like the code to duplicate till the last day of the month in K1. any help is greatly appreciated

RSS New Exception Log Layout.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1											Tuesday, December 1, 2020
2	EE#	LAST NAME	FIRST NAME	PT/FT STATUS	SCHEDULE	ACTUAL	OT	DT	MDT	SUP INITIAL	REMARKS
3	1234	KORE	KURD	FT
4	12345	JOHN	SMITH	FT
5	123456	PAUL	SMITH	FT
6	6548	CHRIS	HALL	FT
7	24568	TONY	WHITE	FT
8	35483	JAMES	BLACK	FT
02

Cell Formulas
Range	Formula
E3	E3	=IFERROR(IF(L$1=TRUE,INDEX('RSS BID'!$D$3:$J$102,MATCH(A3,'RSS BID'!$A$3:$A$102,0),MATCH(O1,'RSS BID'!$D$2:$J$2,0)),IF($M$1=TRUE,INDEX('RSS BID'!$L$3:$R$102,MATCH(A3,'RSS BID'!$A$3:$A$102,0),MATCH(O1,'RSS BID'!$L$2:$R$2,0)),"")),"")
E4	E4	=IFERROR(IF(L$1=TRUE,INDEX('RSS BID'!$D$3:$J$102,MATCH(A4,'RSS BID'!$A$3:$A$102,0),MATCH(O1,'RSS BID'!$D$2:$J$2,0)),IF($M$1=TRUE,INDEX('RSS BID'!$L$3:$R$102,MATCH(A4,'RSS BID'!$A$3:$A$102,0),MATCH(O1,'RSS BID'!$L$2:$R$2,0)),"")),"")
E5	E5	=IFERROR(IF(L$1=TRUE,INDEX('RSS BID'!$D$3:$J$102,MATCH(A5,'RSS BID'!$A$3:$A$102,0),MATCH(O1,'RSS BID'!$D$2:$J$2,0)),IF($M$1=TRUE,INDEX('RSS BID'!$L$3:$R$102,MATCH(A5,'RSS BID'!$A$3:$A$102,0),MATCH(O1,'RSS BID'!$L$2:$R$2,0)),"")),"")
E6	E6	=IFERROR(IF(L$1=TRUE,INDEX('RSS BID'!$D$3:$J$102,MATCH(A6,'RSS BID'!$A$3:$A$102,0),MATCH(O1,'RSS BID'!$D$2:$J$2,0)),IF($M$1=TRUE,INDEX('RSS BID'!$L$3:$R$102,MATCH(A6,'RSS BID'!$A$3:$A$102,0),MATCH(O1,'RSS BID'!$L$2:$R$2,0)),"")),"")
E7	E7	=IFERROR(IF(L$1=TRUE,INDEX('RSS BID'!$D$3:$J$102,MATCH(A7,'RSS BID'!$A$3:$A$102,0),MATCH(O1,'RSS BID'!$D$2:$J$2,0)),IF($M$1=TRUE,INDEX('RSS BID'!$L$3:$R$102,MATCH(A7,'RSS BID'!$A$3:$A$102,0),MATCH(O1,'RSS BID'!$L$2:$R$2,0)),"")),"")
E8	E8	=IFERROR(IF(L$1=TRUE,INDEX('RSS BID'!$D$3:$J$102,MATCH(A8,'RSS BID'!$A$3:$A$102,0),MATCH(O1,'RSS BID'!$D$2:$J$2,0)),IF($M$1=TRUE,INDEX('RSS BID'!$L$3:$R$102,MATCH(A8,'RSS BID'!$A$3:$A$102,0),MATCH(O1,'RSS BID'!$L$2:$R$2,0)),"")),"")

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
E3:E102	Cell Value	contains "OFF"	text	NO

 

[mumps]

Try:

Sub CreateSheets()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, x As Long, rDate As Date
    Set srcWS = ThisWorkbook.Sheets("Sheet1")
    rDate = srcWS.Range("K1")
    x = Day(Format(Excel.Application.WorksheetFunction.EoMonth(srcWS.Range("K1").Value2, 0), "yyyy-mm-dd"))
    Workbooks.Add 1
    For x = 0 To x - 1
        srcWS.Copy after:=Sheets(Sheets.Count)
        ActiveSheet.Name = Format(rDate + x, "mm-dd")
        Range("K1") = Range("K1") + x
    Next x
    Application.DisplayAlerts = False
    Sheets(1).Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[hajiali]

Thank you so much mumps that works great. I really appreciate this

 

[mumps]

You are very welcome.

 

[hajiali]

if I wanted to add the following to save the new workbook in the file path and file name where would I the below code?

 ActiveWorkbook.SaveAs Filename:= _
        "\\C:\books\" & Range("N4") & " " & Range("N5") & ".xlsx ", FileFormat _
        :=xlOpenXMLWorkbook, CreateBackup:=False

 

[mumps]

In which sheet are Range("N4") and Range("N5")?

 

[hajiali]

they will be on all sheets in the new workbook. Range("N4") is just the month of the value in K1. but its being copied to all sheets.

 

[mumps]

Try:

Sub CreateSheets()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, x As Long, rDate As Date
    Set srcWS = ThisWorkbook.Sheets("Sheet1")
    rDate = srcWS.Range("K1")
    x = Day(Format(Excel.Application.WorksheetFunction.EoMonth(srcWS.Range("K1").Value2, 0), "yyyy-mm-dd"))
    Workbooks.Add 1
    For x = 0 To x - 1
        srcWS.Copy after:=Sheets(Sheets.Count)
        ActiveSheet.Name = Format(rDate + x, "mm-dd")
        Range("K1") = Range("K1") + x
    Next x
    Application.DisplayAlerts = False
    Sheets(1).Delete
    Application.DisplayAlerts = True
    ActiveWorkbook.SaveAs Filename:="C:\books\" & Range("N4") & " " & Range("N5") & ".xlsx", FileFormat:=51
    Application.ScreenUpdating = True
End Sub

 

[hajiali]

Keep getting the above error on the

ActiveWorkbook.SaveAs Filename:="C:\books\" & Range("N4") & " " & Range("N5") & ".xlsx", FileFormat:=51

the workbook file name changes correctly but I am not even able to manually save it I get the following message

 

[mumps]

There could be many reasons why this is happening and I'm not sure I have a solution for you. Try doing a little research into the problem or open a new thread describing the problem. Perhaps another Forum member with experience with this issue will be able to help you.