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:

Name	Location	Start Date	End Date	Days
John	Canada	January 1, 2013	February 24, 2013	55
Jack	US	February 18, 2013	March 23, 2013	34

<TBODY>
</TBODY>

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

Name	Location	Start Date	End Date	Days
John	Canada	January 1, 2013	January 31, 2013	31
John	Canada	February 1, 2013	February 24, 2013	24
Jack	US	February 18, 2013	February 28, 2013	11
Jack	US	March 1, 2013	March 23, 2013	23

<TBODY>
</TBODY>

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.

Name Location Start Date End Date Months John Canada 1/1/2016 2/24/2020 50 Jack US 2/18/2017 3/23/2023 74 Results Name Location Start Date End Date Months John Canada 1/1/2016 3/31/2016 3 John Canada 4/1/2016 3/31/2017 12 John Canada 4/1/2017 3/31/2018 12 John Canada 4/1/2018 3/31/2019 12 John Canada 4/1/2018 2/24/2020 23 Jack US 2/18/2017 3/31/2017 1 Jack US 4/1/2017 3/31/2018 12 Jack US 4/1/2018 3/31/2019 12 Jack US 4/1/2019 3/31/2020 12 Jack US 4/1/2020 3/31/2021 12 Jack US 4/1/2021 3/31/2022 12 Jack US 4/1/2022 3/23/2023 12 <colgroup><col span="2"><col><col><col></colgroup><tbody> </tbody>

<tbody>
</tbody>

 

[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
]