excel: create calendar worksheet based on column data

Sub CreateMonthSheets()
Dim Sws As Worksheet, Dws As Worksheet
Dim Slr As Long
Dim Srng As Range, Cell As Range

Application.ScreenUpdating = False

Set Sws = Sheets("Data")            'Source Sheet, Data Sheet in this example
Slr = Sws.Cells(Rows.Count, 1).End(xlUp).Row        'Slr is the last row with data in Date Column A. Here 1 stands for col. A index number so if the Date column is B, 1 should be changed to 2.
Set Srng = Sws.Range("A2:A" & Slr)      'Srng assumes that the Dates are in col. A starting from Row2

For Each Cell In Srng
    If Sws.Cells(Cell.Row, "AA") <> "Y" Then        'The code checks if the corresponding cell AA doesn't have a Y in it as when the row is copied first time the code puts a "Y" in the cell AA of that row, therefore it would not be copied next time.
        On Error Resume Next
        Set Dws = Sheets(Format(Cell, "mmm-yy"))        'This will be name of the month sheet and if the month sheet is not present it will produce an error and the control passes to the next IF block assuming Err<>0 and will create a new month sheet to have data
        If Err <> 0 Then
            Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = Format(Cell, "mmm-yy")   'Adds a worksheet and name it with the mmm-yy format of the date
            Set Dws = ActiveSheet
            Dws.Range("A1").Value = "Date Evaluation Due"       'The next few lines place the columns headers in the month sheets and format them
            Dws.Range("B1").Value = "Id"
            Dws.Range("A1:B1").Font.Bold = True
            Dws.Range("A1:B1").HorizontalAlignment = xlCenter
        End If
        On Error GoTo 0
        '1 in the below line is the column index number of col. A and 2 is the column index number of col. B, change them as per your requirement.
        'Dws.Range("A" & Rows.Count).End(3)(2) will be the first empty cell in col. L, change it if you want to change the destination column
        Sws.Range(Sws.Cells(Cell.Row, 1), Sws.Cells(Cell.Row, 2)).Copy Dws.Range("A" & Rows.Count).End(3)(2)
        Sws.Cells(Cell.Row, "AA") = "Y"     'Once a row is copied to its relevant month sheet, the code puts a "Y" in the corresponding cell in col. AA to confirm that the row has been transferred to the months sheet.
        Application.CutCopyMode = 0
        Dws.UsedRange.Columns.AutoFit
    End If
Next Cell

Sws.Activate
Application.ScreenUpdating = True
MsgBox "Data has been transferred to the Months Sheets successfully.", vbInformation, "Done!"
End Sub

Select allOpen in new window

Slr = Sws.Cells(Rows.Count, "Y").End(xlUp).Row        'Slr is the last row with data in Date Column Y. 
Set Srng = Sws.Range("Y2:Y" & Slr)      'Srng (Range) assumes that the Dates are in col. Y starting from Row2

Select allOpen in new window

Sws.Range(Sws.Cells(Cell.Row, "Y"), Sws.Cells(Cell.Row, "Z")).Copy Dws.Range("A" & Rows.Count).End(3)(2)

Select allOpen in new window