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

nkashyap3

New Member
Joined
Jun 27, 2019
Messages
23
Office Version
  1. 2010
Platform
  1. Windows
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)
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

shknbk2

Active Member
Joined
Mar 5, 2016
Messages
385
Office Version
  1. 365
Platform
  1. Windows
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.

Code:
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

New Member
Joined
Jun 27, 2019
Messages
23
Office Version
  1. 2010
Platform
  1. Windows
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

Active Member
Joined
Mar 5, 2016
Messages
385
Office Version
  1. 365
Platform
  1. Windows
Here is a revision:
Code:
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
 

Forum statistics

Threads
1,136,434
Messages
5,675,841
Members
419,586
Latest member
RoteichA

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top