VB Code to convert Quarter data into Monthly data

[rmomin]

Hello:

Please refer to attached file.
I have Quarterly Gross Earning report for employees as shown.
Data shows 2nd Qtr ending (6/30/2020) and 3rd Qtr Ending (9/30/2020).

I need VB Code to split this data into Monthly instead of Quarterly by
dividing 3 each earning in column D as example

Data shows 2nd row,
6/30/2020 Alyssa Mccoon $2990.31
So split this data as
4/30/2020 Alyssa Mccoon $976.77
5/31/2020 Alyssa Mccoon $976.77
6/30/2020 Alyssa Mccoon $976.77

Manually completed data is shown in Sheet2

Please let me know if you have any questions.
Thanks.

R

[alansidman]

A power query solution

let
    Source = Excel.CurrentWorkbook(){[Name="Table3"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Date", type date}, {"TotInc", Currency.Type}}),
    #"Added Custom" = Table.AddColumn(#"Changed Type", "Custom", each [TotInc] / 3),
    #"Changed Type1" = Table.TransformColumnTypes(#"Added Custom",{{"Custom", Currency.Type}}),
    #"Added Custom1" = Table.AddColumn(#"Changed Type1", "Custom.1", each Date.AddMonths([Date],-1)),
    #"Added Custom2" = Table.AddColumn(#"Added Custom1", "Custom.2", each Date.AddMonths([Date],-2)),
    #"Merged Columns" = Table.CombineColumns(Table.TransformColumnTypes(#"Added Custom2", {{"Date", type text}, {"Custom.1", type text}, {"Custom.2", type text}}, "en-US"),{"Date", "Custom.1", "Custom.2"},Combiner.CombineTextByDelimiter(":", QuoteStyle.None),"Merged"),
    #"Removed Columns" = Table.RemoveColumns(#"Merged Columns",{"TotInc"}),
    #"Split Column by Delimiter" = Table.ExpandListColumn(Table.TransformColumns(#"Removed Columns", {{"Merged", Splitter.SplitTextByDelimiter(":", QuoteStyle.Csv), let itemType = (type nullable text) meta [Serialized.Text = true] in type {itemType}}}), "Merged")
in
    #"Split Column by Delimiter"

[Marc L]

Manually completed data is shown in Sheet2

Hello,

so the reason why so many dates errors or your initial explanation does not match your expected result ?!

[PCI]

See next code in Sheet1 code module

Option Explicit

Sub Prepa()
Const DstCol = 7
Dim LR As Long, I As Long
Dim Totinc As Single, MonInc As Single
Dim EmpN As String
Dim QDate As Date, M1Date As Date, M2Date As Date, M3Date As Date
    LR = Cells(Rows.Count, "B").End(3).Row
    Range("B1").Resize(1, 3).Copy Cells(1, DstCol)
    Application.ScreenUpdating = False
    For I = 2 To LR
        QDate = Cells(I, 2)
        EmpN = Cells(I, 3)
        Totinc = Cells(I, 4)
        MonInc = Totinc / 3
        M1Date = DateSerial(Year(QDate), Month(QDate) - 1, 1) - 1
        M2Date = DateSerial(Year(QDate), Month(QDate), 1) - 1
        M3Date = DateSerial(Year(QDate), Month(QDate) + 1, 1) - 1
        Cells(Rows.Count, DstCol).End(3)(2).Resize(1, 3) = Array(M1Date, EmpN, MonInc)
        Cells(Rows.Count, DstCol).End(3)(2).Resize(1, 3) = Array(M2Date, EmpN, MonInc)
        Cells(Rows.Count, DstCol).End(3)(2).Resize(1, 3) = Array(M3Date, EmpN, MonInc)
    Next I
    Application.ScreenUpdating = True
End Sub

[HansDouwe]

Or try a formula

=MAKEARRAY(3*ROWS(Table3),3,LAMBDA(r,c,CHOOSE(c,EOMONTH(INDEX(Table3,(r+2)/3,c),MOD(r-1,3)-2),INDEX(Table3,(r+2)/3,c),INDEX(Table3,(r+2)/3,c)/3)))

[rizmomin]

Hello
Thanks to all
I will be using PCI's code

R

[PCI]

Super, while others suggestions are really great.
Thx for the Rep

[kvsrinivasamurthy]

Here is another code which gives result as shown by you.
Code

Sub QuarterToMonthly()
Dim A, B, C, D
Dim Qdt As Date
Dim T As Long, X As Long, Mth As Long
Dim Val As Double
If ActiveSheet.Name <> "Sheet1" Then Sheets("Sheet1").Activate
Sheets("Sheet2").Range("B1").CurrentRegion.Offset(1, 0).ClearContents

With Range("B1").CurrentRegion
A = .Offset(1, 0).Value
End With
ReDim B(1 To UBound(A, 1), 1 To 3)
ReDim C(1 To UBound(A, 1), 1 To 3)
ReDim D(1 To UBound(A, 1), 1 To 3)

With Sheets("Sheet2")
.[B1] = "Date": .[C1] = "EmpName": .[D1] = "TotInc"
End With
For T = 1 To UBound(A, 1) - 1
X = X + 1
B(X, 1) = WorksheetFunction.EoMonth(A(T, 1), -2)
C(X, 1) = WorksheetFunction.EoMonth(A(T, 1), -1)
D(X, 1) = A(T, 1)
Val = Round(A(T, 3) / 3, 2)
B(X, 2) = A(T, 2): B(X, 3) = Val
C(X, 2) = A(T, 2): C(X, 3) = Val
D(X, 2) = A(T, 2): D(X, 3) = Val

If T = UBound(A, 1) - 1 Or A(T, 1) <> A(T + 1, 1) Then

With Sheets("Sheet2")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Resize(3 * X, 1).NumberFormat = "m/d/yyyy"
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Resize(X, 3) = B
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Resize(X, 3) = C
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Resize(X, 3) = D
End With
X = 0

End If
Next T

End Sub