Excel VBA or Formula to Split Period of Months into Individual Month

[zakkair]

Hi guys,

I have a sheet with data similar to the following table:

[TABLE="width: 500"]
<TBODY>[TR]
[TD]Name
[/TD]
[TD]Location
[/TD]
[TD]Start Date
[/TD]
[TD]End Date
[/TD]
[TD]Days
[/TD]
[/TR]
[TR]
[TD]John
[/TD]
[TD]Canada
[/TD]
[TD]January 1, 2013
[/TD]
[TD]February 24, 2013
[/TD]
[TD]55
[/TD]
[/TR]
[TR]
[TD]Jack
[/TD]
[TD]US
[/TD]
[TD]February 18, 2013
[/TD]
[TD]March 23, 2013
[/TD]
[TD]34
[/TD]
[/TR]
</TBODY>[/TABLE]


Is it possible to create an Excel formula or VBA to split this set of data into individual months such that it looks like this

[TABLE="width: 500"]
<TBODY>[TR]
[TD]Name
[/TD]
[TD]Location
[/TD]
[TD]Start Date
[/TD]
[TD]End Date
[/TD]
[TD]Days
[/TD]
[/TR]
[TR]
[TD]John
[/TD]
[TD]Canada
[/TD]
[TD]January 1, 2013
[/TD]
[TD]January 31, 2013
[/TD]
[TD]31
[/TD]
[/TR]
[TR]
[TD]John
[/TD]
[TD]Canada
[/TD]
[TD]February 1, 2013
[/TD]
[TD]February 24, 2013
[/TD]
[TD]24
[/TD]
[/TR]
[TR]
[TD]Jack
[/TD]
[TD]US
[/TD]
[TD]February 18, 2013
[/TD]
[TD]February 28, 2013
[/TD]
[TD]11
[/TD]
[/TR]
[TR]
[TD]Jack
[/TD]
[TD]US
[/TD]
[TD]March 1, 2013
[/TD]
[TD]March 23, 2013
[/TD]
[TD]23
[/TD]
[/TR]
</TBODY>[/TABLE]


Thanks for any help I can get!

 

[Momentman]

This macro should do the trick. Be sure those dates are formatted as dates and recognized as such

Sub adjustmonth()
    Dim I As Integer
    Dim lastrow As Integer
    Dim wf As WorksheetFunction
    
    Set wf = Application.WorksheetFunction
    
    lastrow = Range("A1").End(xlDown).Row
    
    For I = lastrow To 2 Step -1
        a = Range("C" & I).Value
        b = Range("D" & I).Value
        diff = (Year(b) - Year(a)) * 12 + Month(b) - Month(a)
        If diff > 0 Then
            Range("D" & I).Value = wf.EoMonth(a, 0)
            Range("E" & I).Value = Range("D" & I).Value - Range("C" & I).Value + 1
                
            For k = 1 To diff
                Rows(I + k).Resize(1).Insert
                Range("A" & I + k).Value = Range("A" & I + k - 1).Value
                Range("B" & I + k).Value = Range("B" & I + k - 1).Value
                Range("C" & I + k).Value = Range("D" & I + k - 1).Value + 1
                If k <> diff Then
                    Range("D" & I + k).Value = wf.EoMonth(Range("C" & I + k).Value, 0)
                Else
                    Range("D" & I + k).Value = b
                End If
                Range("E" & I + k).Value = Range("D" & I + k).Value - Range("C" & I + k).Value + 1
            Next k
        End If
    Next I
End Sub

 

[zakkair]

Thank you so much Momentman. The code works flawlessly and is extremely fast too!

 

[Momentman]

You are welcome, Was quite a learning experience for me

 

[zakkair]

Just another quick question regarding the code,

What would I edit if there's another two columns F-G so that they repeat like column A, B, and C when you use the macro?

 

[Momentman]

Maybe not the most efficient of ways but you could add 2 lines like

Range("F" & I + k).Value = Range("F" & I + k - 1).Value

Range("G" & I + k).Value = Range("G" & I + k - 1).Value

Add them underneath the lines that copy for column A, B and C

 

[JPAvila]

This works amazingly. However, can you alter this code to split the dates in 12 months with beginning month of April 1st.

It would be great help.

 

[Momentman]

This works amazingly. However, can you alter this code to split the dates in 12 months with beginning month of April 1st.

It would be great help.

This post is almost 3 years old I probably cant remember how the code even works

Can you give an example of what you really require

 

[JPAvila]

Essentially splitting long periods into 12 months with start of April 1st.

I.e.

[TABLE="class: cms_table, width: 500"]
<tbody>[TR]
[TD][TABLE="width: 588"]
<colgroup><col span="2"><col><col><col></colgroup><tbody>[TR]
[TD]Name[/TD]
[TD]Location[/TD]
[TD]Start Date[/TD]
[TD]End Date[/TD]
[TD]Months [/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]Canada[/TD]
[TD]1/1/2016[/TD]
[TD]2/24/2020[/TD]
[TD="align: right"]50[/TD]
[/TR]
[TR]
[TD]Jack[/TD]
[TD]US[/TD]
[TD]2/18/2017[/TD]
[TD]3/23/2023[/TD]
[TD="align: right"]74[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Results[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name[/TD]
[TD]Location[/TD]
[TD]Start Date[/TD]
[TD]End Date[/TD]
[TD]Months [/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]Canada[/TD]
[TD]1/1/2016[/TD]
[TD]3/31/2016[/TD]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]Canada[/TD]
[TD]4/1/2016[/TD]
[TD]3/31/2017[/TD]
[TD="align: right"]12[/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]Canada[/TD]
[TD]4/1/2017[/TD]
[TD]3/31/2018[/TD]
[TD="align: right"]12[/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]Canada[/TD]
[TD]4/1/2018[/TD]
[TD]3/31/2019[/TD]
[TD="align: right"]12[/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]Canada[/TD]
[TD]4/1/2018[/TD]
[TD]2/24/2020[/TD]
[TD="align: right"]23[/TD]
[/TR]
[TR]
[TD]Jack[/TD]
[TD]US[/TD]
[TD]2/18/2017[/TD]
[TD]3/31/2017[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD]Jack[/TD]
[TD]US[/TD]
[TD]4/1/2017[/TD]
[TD]3/31/2018[/TD]
[TD="align: right"]12[/TD]
[/TR]
[TR]
[TD]Jack[/TD]
[TD]US[/TD]
[TD]4/1/2018[/TD]
[TD]3/31/2019[/TD]
[TD="align: right"]12[/TD]
[/TR]
[TR]
[TD]Jack[/TD]
[TD]US[/TD]
[TD]4/1/2019[/TD]
[TD]3/31/2020[/TD]
[TD="align: right"]12[/TD]
[/TR]
[TR]
[TD]Jack[/TD]
[TD]US[/TD]
[TD]4/1/2020[/TD]
[TD]3/31/2021[/TD]
[TD="align: right"]12[/TD]
[/TR]
[TR]
[TD]Jack[/TD]
[TD]US[/TD]
[TD]4/1/2021[/TD]
[TD]3/31/2022[/TD]
[TD="align: right"]12[/TD]
[/TR]
[TR]
[TD]Jack[/TD]
[TD]US[/TD]
[TD]4/1/2022[/TD]
[TD]3/23/2023[/TD]
[TD="align: right"]12[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[aaleem]

This is superb, thank you so much Momentman.
It gives me a a curiosity to JPAvila request. i tried your code and come out with the below code.

[
Sub adjustYear()
    Dim I As Integer
    Dim lastrow As Integer
    Dim wf As WorksheetFunction
    
    Worksheets("Sheet2").Select
    Set wf = Application.WorksheetFunction
    
    lastrow = Range("A1").End(xlDown).Row
    
    For I = lastrow To 2 Step -1
        a = Range("C" & I).Value
        b = Range("D" & I).Value
        diff = (year(b) - year(a)) ' * 12 ' + Month(b) - Month(a)
        
        If diff > 0 Then
            Range("D" & I).Value = wf.EDate(a, 12) - 1
            Range("E" & I).Value = Range("D" & I).Value - Range("C" & I).Value + 1
                
            For k = 1 To diff
                Rows(I + k).Resize(1).Insert
                Range("A" & I + k).Value = Range("A" & I + k - 1).Value
                Range("B" & I + k).Value = Range("B" & I + k - 1).Value
                Range("C" & I + k).Value = Range("D" & I + k - 1).Value + 1
                If k <> diff Then
                    Range("D" & I + k).Value = wf.EDate(Range("C" & I + k).Value, 12) - 1
                Else
                    Range("D" & I + k).Value = b
                End If
                Range("E" & I + k).Value = Range("D" & I + k).Value - Range("C" & I + k).Value + 1
            Next k
        End If
    Next I
End Sub
]