make records for every 15 days according to startdate to end date

[nkashyap3]

Hi friends,


I need help in Vba code. i am stuck on one part of report I am preparing the report there are multipal emp Id in A column there are two dates in column D (Start date) and column E(end date). I want make multipal records of one emp Id , records will create for 15 days group of each month. emp id count is not fixed every month change example


column A column B column c column d column e
Empl ID Employee Name New Explanation Exception Start Date Exception End Date
0645801 Leslie, Gail Disability 01/01/2019 02/28/2019
0996672 Onderdonk, Regina Disability 08/06/2019 12/31/2019
1006307 Patel,Jagruti K DEPT Change 01/01/2019 05/31/2019
1006591 Yu,Laura Disability 06/01/2019 12/31/2019


my condition are.


1- if stare date is 01/01/2019 and end date 01/15/2019. ( no change copy the raw and paste on sheet tab(Exception List MTD))
2 -if start 01/01/2019 and end date 01/19/2019. (we create 2 for same emp id like below


Empl ID Employee Name New Explanation Exception Start Date Exception End Date
0645801 Leslie, Gail Disability 01/01/2019 01/15/2019
0645801 Leslie, Gail Disability 01/16/2019 01/19/2019


now copy the both records and paste on sheet tab(Exception List MTD)








3- if start 08/06/2019 and end date 12/31/2019. (we create 10 records for same emp id like below
Empl ID Employee Name New Explanation Exception Start Date Exception End Date
0996672 Onderdonk, Regina Disability 08/06/2019 08/15/2019
0996672 Onderdonk, Regina Disability 08/16/2019 08/31/2019
0996672 Onderdonk, Regina Disability 09/01/2019 09/15/2019
0996672 Onderdonk, Regina Disability 09/16/2019 09/30/2019
0996672 Onderdonk, Regina Disability 10/01/2019 10/15/2019
0996672 Onderdonk, Regina Disability 10/16/2019 10/31/2019
0996672 Onderdonk, Regina Disability 11/01/2019 11/15/2019
0996672 Onderdonk, Regina Disability 11/16/2019 11/30/2019
0996672 Onderdonk, Regina Disability 12/01/2019 12/15/2019
0996672 Onderdonk, Regina Disability 12/15/2019 12/31/2019




now copy the records and paste on sheet tab(Exception List MTD)

 

[shknbk2]

How about something like this?

Thanks to HERE for giving me a quick find to solve the days-of-the-month issue without thinking too hard.

Sub nkashyap3()
    Dim startDate As Date
    Dim endDate As Date
    Dim midDate As Date
    
    Range("A2").Select
    Do Until ActiveCell.Value = ""
        startDate = ActiveCell.Offset(0, 3).Value
        endDate = ActiveCell.Offset(0, 4).Value
        midDate = 0
        If Day(startDate) <= 15 And Day(endDate) > 15 Then
            midDate = DateSerial(Year(startDate), Month(startDate), 15)
        ElseIf Month(startDate) <> Month(endDate) Or Year(startDate) <> Year(endDate) Then
            midDate = DateSerial(Year(startDate), Month(startDate), NB_DAYS(startDate))
        End If
        
        If midDate > 0 Then
            ActiveCell.Offset(1, 0).EntireRow.Insert xlDown
            ActiveCell.EntireRow.Copy ActiveCell.Offset(1, 0)
            ActiveCell.Offset(0, 4).Value = midDate
            ActiveCell.Offset(1, 0).Select
            ActiveCell.Offset(0, 3).Value = midDate + 1
        Else
            ActiveCell.Offset(1, 0).Select
        End If
    Loop
    Range("A2").CurrentRegion.Resize(Range("A2").CurrentRegion.Rows.Count - 1).Offset(1, 0).Select
    Selection.Copy Worksheets("Exception List MTD").Cells(Worksheets("Exception List MTD").Rows.Count, 1).End(xlUp).Offset(1, 0)
End Sub

Function NB_DAYS(date_test As Date) As Integer
    NB_DAYS = Day(DateSerial(Year(date_test), Month(date_test) + 1, 1) - 1)
End Function

 

[nkashyap3]

Hi

thanks for this help and you code is working fine some records not make copy as I want
for example if start date is 01/01/2019 and end date is 09/01/2019. in this condition coding create 9 records 17 records.
second example if start date s 01/01/2019 end date is 05/19/ 2019, code create 5 records 10 records we need ,

please help to rectify this

 

[shknbk2]

Here is a revision:

Sub nkashyap3()
    Dim startDate As Date
    Dim endDate As Date
    Dim midDate As Date
    
    Application.ScreenUpdating = False
    Range("A2").Select
    Do Until ActiveCell.Value = ""
        startDate = ActiveCell.Offset(0, 3).Value
        endDate = ActiveCell.Offset(0, 4).Value
        midDate = 0
        If Day(startDate) <= 15 And (Day(endDate) > 15 Or Month(startDate) <> Month(endDate) Or Year(startDate) <> Year(endDate)) Then
            midDate = DateSerial(Year(startDate), Month(startDate), 15)
        ElseIf Month(startDate) <> Month(endDate) Or Year(startDate) <> Year(endDate) Then
            midDate = DateSerial(Year(startDate), Month(startDate), NB_DAYS(startDate))
        End If
        
        If midDate > 0 Then
            ActiveCell.Offset(1, 0).EntireRow.Insert xlDown
            ActiveCell.EntireRow.Copy ActiveCell.Offset(1, 0)
            ActiveCell.Offset(0, 4).Value = midDate
            ActiveCell.Offset(1, 0).Select
            ActiveCell.Offset(0, 3).Value = midDate + 1
        Else
            ActiveCell.Offset(1, 0).Select
        End If
    Loop
    Range("A2").CurrentRegion.Resize(Range("A2").CurrentRegion.Rows.Count - 1).Offset(1, 0).Select
    Selection.Copy Worksheets("Exception List MTD").Cells(Worksheets("Exception List MTD").Rows.Count, 1).End(xlUp).Offset(1, 0)
    Application.ScreenUpdating = True
End Sub

Function NB_DAYS(date_test As Date) As Integer
    NB_DAYS = Day(DateSerial(Year(date_test), Month(date_test) + 1, 1) - 1)
End Function