Duplicate entries based on start and end date

[rubbis_with_excel]

Hi,
I have some data with start and end dates, and I need to build some VBA to duplicate lines so there are month-specific entries. Hopefully this example *might* explain it

If the raw data looks like this:
<b>Name___Start Date___End Date</b>
Person1__01/01/2019___31/03/2019
Person2__10/10/2019___11/11/2019

I want to be able to convert it to:
<b>Name___Start Date___End Date</b>
Person1__01/01/2019___31/01/2019
Person1__01/02/2019___28/02/2019
Person1__01/03/2019___31/03/2019
Person2__10/10/2019___31/10/2019
Person2__01/11/2019___11/11/2019

So that each month is represented on a different row.

I've been racking my brains for hours and I just can't get it to work!

If anyone has any ideas, I would be very grateful.

Thanks

 

[Joe4]

Try this (I added lots of documentation so hopefully you can see how it works):

Sub MyInsertRows()

    Dim r As Long
    Dim dteStart As Date
    Dim dteEnd As Date
    Dim dteEOM As Date
    Dim nm As String

    Application.ScreenUpdating = False
    
'   Specify first row data appears on
    r = 2
    
'   Loop through all records
    Do Until Cells(r, "B") = ""
'       Get current values
        nm = Cells(r, "A")
        dteStart = Cells(r, "B")
        dteEnd = Cells(r, "C")
'       Calculate end of month date from start date
        dteEOM = DateSerial(Year(dteStart), Month(dteStart) + 1, 0)
'       Check to see if current end date greater than end of month date
        If dteEnd > dteEOM Then
'           Insert record and update dates
            Rows(r + 1).Insert
'           Update End date on current record
            Cells(r, "C") = dteEOM
'           Add values for new record
            Cells(r + 1, "A") = nm
            Cells(r + 1, "B") = dteEOM + 1
            Cells(r + 1, "C") = dteEnd
        End If
'       Increment row counter
        r = r + 1
    Loop
    
    Application.ScreenUpdating = True
    
End Sub

Note that I am assuming your data is in columns A, B, and C, and the header row is row 1 and the data starts on row 2.

 

[rubbis_with_excel]

That is GENIUS.

Thank you so much, that is absolutely perfect!!!

 

[Joe4]

You are welcome.
Glad I was able to help!

 

[Entrylevel]

Try this (I added lots of documentation so hopefully you can see how it works):

Sub MyInsertRows()

    Dim r As Long
    Dim dteStart As Date
    Dim dteEnd As Date
    Dim dteEOM As Date
    Dim nm As String

    Application.ScreenUpdating = False
   
'   Specify first row data appears on
    r = 2
   
'   Loop through all records
    Do Until Cells(r, "B") = ""
'       Get current values
        nm = Cells(r, "A")
        dteStart = Cells(r, "B")
        dteEnd = Cells(r, "C")
'       Calculate end of month date from start date
        dteEOM = DateSerial(Year(dteStart), Month(dteStart) + 1, 0)
'       Check to see if current end date greater than end of month date
        If dteEnd > dteEOM Then
'           Insert record and update dates
            Rows(r + 1).Insert
'           Update End date on current record
            Cells(r, "C") = dteEOM
'           Add values for new record
            Cells(r + 1, "A") = nm
            Cells(r + 1, "B") = dteEOM + 1
            Cells(r + 1, "C") = dteEnd
        End If
'       Increment row counter
        r = r + 1
    Loop
   
    Application.ScreenUpdating = True
   
End Sub

Note that I am assuming your data is in columns A, B, and C, and the header row is row 1 and the data starts on row 2.

Hello Jeo4,

Thank you for transfer the information, I really need your support in this I have tried to do the same but in vain, I'm a beginner in Excel and I have weak skills in implementing the above in Macro, So if you could do a short video to facilitate this to me it will be appreciated.

Thanks

 

[Joe4]

Hello Jeo4,

Thank you for transfer the information, I really need your support in this I have tried to do the same but in vain, I'm a beginner in Excel and I have weak skills in implementing the above in Macro, So if you could do a short video to facilitate this to me it will be appreciated.

Thanks

Please show us a sample of your data so we can see how it is laid out and what format it is in.

 

[Entrylevel]

Please show us a sample of your data so we can see how it is laid out and what format it is in.

Thank you for your prompt response.

Employee Name	Date Start	Date End	Duration
x	19/08/2024	25/08/2024	7 Days

I need it to be duplicated 7 times the same as above, I have tried to use the formula you gave but in vain.

Thank you again for your support

 

[Joe4]

Note the code I posted splits up the dates by months, not days.

 

[Joe4]

If you are looking to take this:

and get to this:

you could use this code:

Sub MyInsertRows()

    Dim r As Long
    Dim dteStart As Date
    Dim dteEnd As Date
    Dim dteNew As Date
    Dim nm As String
    Dim i As Long, n As Long

    Application.ScreenUpdating = False
    
'   Specify first row data appears on
    r = 2
    
'   Loop through all records
    Do Until Cells(r, "B") = ""
'       Get current values
        nm = Cells(r, "A")
        dteStart = Cells(r, "B")
        dteEnd = Cells(r, "C")
'       See if we need to insert dates
        If dteEnd > dteStart Then
'           Count loops
            n = dteEnd - dteStart
'           Loop
            For i = 1 To n
'               Insert record and update dates
                Rows(r + 1).Insert
'               Add values for new record
                Cells(r + 1, "A") = nm
                Cells(r + 1, "B") = dteStart + i
                Cells(r + 1, "C") = dteStart + i
                Cells(r + 1, "D") = "1 Day"
'               Increment row counter
                r = r + 1
            Next i
        Else
'           Move to next row
            r = r + 1
        End If
    Loop
    
    Application.ScreenUpdating = True
    
End Sub

 

[Entrylevel]

If you are looking to take this:

View attachment 115958

and get to this:

View attachment 115959

you could use this code:

Sub MyInsertRows()

    Dim r As Long
    Dim dteStart As Date
    Dim dteEnd As Date
    Dim dteNew As Date
    Dim nm As String
    Dim i As Long, n As Long

    Application.ScreenUpdating = False
  
'   Specify first row data appears on
    r = 2
  
'   Loop through all records
    Do Until Cells(r, "B") = ""
'       Get current values
        nm = Cells(r, "A")
        dteStart = Cells(r, "B")
        dteEnd = Cells(r, "C")
'       See if we need to insert dates
        If dteEnd > dteStart Then
'           Count loops
            n = dteEnd - dteStart
'           Loop
            For i = 1 To n
'               Insert record and update dates
                Rows(r + 1).Insert
'               Add values for new record
                Cells(r + 1, "A") = nm
                Cells(r + 1, "B") = dteStart + i
                Cells(r + 1, "C") = dteStart + i
                Cells(r + 1, "D") = "1 Day"
'               Increment row counter
                r = r + 1
            Next i
        Else
'           Move to next row
            r = r + 1
        End If
    Loop
  
    Application.ScreenUpdating = True
  
End Sub
[/
[/QUOTE]

If you are looking to take this:

View attachment 115958

and get to this:

View attachment 115959

you could use this code:

Sub MyInsertRows()

    Dim r As Long
    Dim dteStart As Date
    Dim dteEnd As Date
    Dim dteNew As Date
    Dim nm As String
    Dim i As Long, n As Long

    Application.ScreenUpdating = False
   
'   Specify first row data appears on
    r = 2
   
'   Loop through all records
    Do Until Cells(r, "B") = ""
'       Get current values
        nm = Cells(r, "A")
        dteStart = Cells(r, "B")
        dteEnd = Cells(r, "C")
'       See if we need to insert dates
        If dteEnd > dteStart Then
'           Count loops
            n = dteEnd - dteStart
'           Loop
            For i = 1 To n
'               Insert record and update dates
                Rows(r + 1).Insert
'               Add values for new record
                Cells(r + 1, "A") = nm
                Cells(r + 1, "B") = dteStart + i
                Cells(r + 1, "C") = dteStart + i
                Cells(r + 1, "D") = "1 Day"
'               Increment row counter
                r = r + 1
            Next i
        Else
'           Move to next row
            r = r + 1
        End If
    Loop
   
    Application.ScreenUpdating = True
   
End Sub

Many thanks for your support, you are the Excel legend, and I really appreciate your support.

Finally I can use this formula without wasting any time.

How can I see your posted to learn more from you ?