Distribute allocation per month - Macro improvement

[JCabral]

Good afternoon

Once again asking for help improving a Macro that I developed but it is taking a while to calculate

So this is the problem I have:
- I have tab GE_DF a set of tasks that have a certain assignment for a Start and End Date of the task;

What I need:
- Know for each month of Column "A" in DATAGraphicos, what is the total contribution of the percentages of allocations for each task and fill in Column "B"

Already presenting the manual calculation made for the first 5 tasks and Macro to make this calculation in VBA, I also limited the calculation to the first 5 tasks just for testing.

I think the routine is taking too long and my call for help is precisely to see if there is another faster method of doing what I want.

Thank you

[queuesef]

It looks like you could use a Pivot table for this, however, the data needs to be NORMALIZED (like it would need to be in a Database). I took your headings and added PERIOD to it. For Each task with multiple dates, I used the period (YYYYMM ~ YYYY = Year & MM~= Month)...by having this you can easily construct a pivot table that will get you your results. I included the TASK in the Pivot table for presentation, but you may not need it (and if you DELETE it my moving it off of the COLUMN Section [ drag it outside of Column Box in Pivot Table~ you will get your summarized results]). It's an approach that will work.

Bueno suerte!

[maras_mak]

Test my code

Sub Fill_table() 
    Dim i As Integer 
    Dim f As String, h As String, e As String 
    Dim rng_GE As Range, rng_Data As Range 
     
    With Sheets("GE_DF") 
        Set rng_GE = .Range("A17:H" & .Cells(Rows.Count, "A").End(xlUp).Row) 
    End With 
    With Sheets("DATAGraficos") 
        Set rng_Data = .Range("A3:A" & .Cells(Rows.Count, "A").End(xlUp).Row) 
        For i = 1 To rng_GE.Rows.Count 
            e = "'GE_DF'!" & rng_GE.Cells(i, 5).Address 
            f = "'GE_DF'!" & rng_GE.Cells(i, 6).Address 
            h = "'GE_DF'!" & rng_GE.Cells(i, 8).Address 
            With .[C3].Resize(rng_Data.Rows.Count, 1).Offset(0, i) 
                .Formula = "=IF(AND(A3>=" & f & ",A3<=" & h & ")," & e & ","""")" 
                .Value = .Value 
            End With 
        Next 
    End With 
    Set rng_Data = Nothing 
    Set rng_GE = Nothing 
End Sub  

[JCabral]

Hi queuesef

Thank you very much for your solution, but it is not possible to change the layout of the tab "GE_DF", which I show is part of a larger layout.

What I need is just the total data per month, and then build a graph.

Thanks for your solution

[JCabral]

Hi maras_mak

Thank you so much for your solution.

What I only want is the total per month, I only put the gray part to show how the calculation would be done if it was done manually.
In the original spreadsheet, these columns do not exist so I just need the final result, which is in column "B" of "DATAGraphicos".

Is it possible to adapt your code to give only the final result?

Thank you very much

Jorge Cabral

[maras_mak]

Yes, of course, please ...

Sub Fill_table() 
    Dim i As Integer 
    Dim f As String, h As String, e As String 
    Dim rng_GE As Range, rng_Data As Range 
     
    With Sheets("GE_DF") 
        Set rng_GE = .Range("A17:H" & .Cells(Rows.Count, "A").End(xlUp).Row) 
    End With 
    With Sheets("DATAGraficos") 
        Set rng_Data = .Range("A3:A" & .Cells(Rows.Count, "A").End(xlUp).Row) 
        For i = 1 To rng_GE.Rows.Count 
            e = "'GE_DF'!" & rng_GE.Cells(i, 5).Address 
            f = "'GE_DF'!" & rng_GE.Cells(i, 6).Address 
            h = "'GE_DF'!" & rng_GE.Cells(i, 8).Address 
            With .[C3].Resize(rng_Data.Rows.Count, 1).Offset(0, i) 
                .Formula = "=IF(AND(A3>=" & f & ",A3<=" & h & ")," & e & ","""")" 
                .Value = .Value 
            End With 
        Next 
        With .[B3].Resize(rng_Data.Rows.Count, 1) 
                .Formula = "=SUM(D3:BK3)" 
                .Value = .Value 
            End With 
    End With 
    Set rng_Data = Nothing 
    Set rng_GE = Nothing 
End Sub  

[JCabral]

Hi maras_mak

Sorry I wasn't completely clear on the result I need.

The columns, "C: BK" cannot exist, as they are here, as in my definitive layout, the columns have other values to make a graph.

In this example I include those data only and exclusively to illustrate which result I intended to appear to me in column "B", total and final results, of the "DATAGraphics" tab.

So I wanted to see the final values in column "B", and no partial values in the adjacent columns.

Is it possible to do that?

Thank you so much again
Jorge

[maras_mak]

My mistake. It will be fine now.

Sub Fill_table() 
    Dim i As Integer, ii As Integer, lr As Integer 
    Dim a_GE(), a_DA() 
     
    With Sheets("GE_DF") 
        a_GE = .Range("E17:H" & .Cells(Rows.Count, "A").End(xlUp).Row).Value 
    End With 
    With Sheets("DATAGraficos") 
        lr = .Cells(Rows.Count, "A").End(xlUp).Row 
        .Range("B3:B" & lr + 2).ClearContents 
        a_DA = .Range("A3:B" & lr).Value 
        For i = 1 To UBound(a_GE) 
            For ii = 1 To UBound(a_DA) 
                If a_DA(ii, 1) >= a_GE(i, 2) And a_DA(ii, 1) <= a_GE(i, 4) Then _ 
                                            a_DA(ii, 2) = a_DA(ii, 2) + a_GE(i, 1) 
            Next ii 
        Next i 
        .[B3].Resize(UBound(a_DA)) = Application.Index(a_DA, 0, 2) 
    End With 
End Sub  

[JCabral]

PERFECT!

Thank you so much again
Jorge