VBA Sum Records Which Match Monthly Column Heading

[hobbiton73]

Hi, I wonder whether someone may be able to help me please.

With some help along the way and with some adaptation by myself, I’ve put together the following code

'Define Constants to indicate use of OVERHEADS or PROJECTS
Const nUseAllDIR As Integer = 1
Const nUseAllEH As Integer = 2
Const nUseAllIND As Integer = 3
Const nUseAllOVH As Integer = 4
Const nUseAllPRO As Integer = 5

Sub ActivitiesForecasts()
'    'This is the Direct Activities routine
'    'It calls the Direct Activities, Enhancements, Indirect Activities, Overheads and Projects routine with the Indirect Activities option
    Call ActivitiesForecastsExtract(nUseAllDIR)
    Call ActivitiesForecastsExtract(nUseAllEH)
    Call ActivitiesForecastsExtract(nUseAllIND)
    Call ActivitiesForecastsExtract(nUseAllOVH)
    Call ActivitiesForecastsExtract(nUseAllPRO)
End Sub

Sub ActivitiesForecastsExtract(iOption As Integer)
    'This is the Direct Activities, Enhancements, Indirect Activities, Overheads or Projects routine
    '
    'Input option iOption has the following possible enumerated values:
    '  a. nUseAllDIR - process for Direct Activities
    '  b. nUseAllEH  - process for Enhancements
    '  c. nUseAllIND - process for Indirect Activities
    '  d. nUseAllOVH  - process for Overheads
    '  e. nUseAllPRO - process for Projects
    
    Dim a
    Dim ad As Worksheet
    Dim bottomB As Integer
    Dim dic As Object
    Dim i As Long
    Dim Mmonth
    Dim rng As Range
    Dim ws As Worksheet
    Dim Y()
    
    'Define a boolean Value which is 'True' if Column 'C' Consultancy and Requirements' are met AND 'False' otherwise
    Dim bColumnCIsConsultancyAndRequirements As Boolean

    Application.ScreenUpdating = False
    
    Set ad = Sheets("All Data")
    
    bottomB = Range("B" & Rows.Count).End(xlUp).Row
                For Each rng In ad.Range("B8:B" & bottomB)
                If rng > 0 Then
        Set ws = Sheets(rng.Value)

    Application.ScreenUpdating = False

    With Worksheets("All Data")
        a = .Range("B8").CurrentRegion ' Load the required range in to array, named "a"
    End With

    Set dic = CreateObject("scripting.dictionary")
    dic.comparemode = 1

    With ws
    With dic
        For i = 2 To UBound(a) ' Loop through rows
            
            'test if column C is "Consultancy & Requirements"
            
            'Initialize to NOT 'Consultancy and Requirements'
            bColumnCIsConsultancyAndRequirements = False
            
            'Test either Direct Activities, Enhancements, Indirect Activities, Overheads or Projects for Column 'C' 'Consultancy and Requirements' conditions
            Select Case iOption
                
                'Direct Activities processing test for Column 'C' 'Consultancy and Requirements' conditions
                Case nUseAllDIR
                If a(i, 1) = ws.Name And InStr(a(i, 6), "Consultancy & Innovation") = 0 And _
                    InStr(a(i, 8), "TM - DIR") > 0 Then
                    
                    'Set the Column 'C' is 'Consultancy & Requirements' boolean value to true
                    'Conditions have been met for Direct Activities
                    bColumnCIsConsultancyAndRequirements = True
                End If
                
                'Enhancements processing test for Column 'C' 'Consultancy and Requirements' conditions
                Case nUseAllEH
                If a(i, 1) = ws.Name And InStr(a(i, 6), "Consultancy & Innovation") = 0 And _
                    InStr(a(i, 8), "Enhancements") > 0 Then
                    
                    'Set the Column 'C' is 'Consultancy & Requirements' boolean value to true
                    'Conditions have been met for Enhancements
                    bColumnCIsConsultancyAndRequirements = True
                End If
                
                'Indirect Activities processing test for Column 'C' 'Consultancy and Requirements' conditions
                Case nUseAllIND
                If a(i, 1) = ws.Name And InStr(a(i, 6), "Consultancy & Innovation") = 0 And _
                    InStr(a(i, 8), "TM - IND") > 0 Then
                    
                    'Set the Column 'C' is 'Consultancy & Requirements' boolean value to true
                    'Conditions have been met for Indirect Activities
                    bColumnCIsConsultancyAndRequirements = True
                End If
                
                'Overheads processing test for Column 'C' 'Consultancy and Requirements' conditions
                Case nUseAllOVH
                If a(i, 1) = ws.Name And InStr(a(i, 6), "Consultancy & Innovation") = 0 And _
                    InStr(a(i, 8), "TM - OVH") > 0 Then
                    
                    'Set the Column 'C' is 'Consultancy & Requirements' boolean value to true
                    'Conditions have been met for Indirect Activities
                    bColumnCIsConsultancyAndRequirements = True
                End If
                
                'Projects processing test for Column 'C' 'Consultancy and Requirements' conditions
                Case nUseAllPRO
                If a(i, 1) = ws.Name And InStr(a(i, 6), "Consultancy & Innovation") = 0 And _
                    InStr(a(i, 8), "TM - ") + _
                    InStr(a(i, 8), "Enhancements") = 0 Then
                    
                    'Set the Column 'C' is 'Consultancy & Requirements' boolean value to true
                    'Conditions have been met for Indirect Activities
                    bColumnCIsConsultancyAndRequirements = True
                End If
                
            End Select
            
            If bColumnCIsConsultancyAndRequirements = True Then 'test if column C is "Consultancy & Requirements"
                Mmonth = Trim(Format(a(i, 12), "mmm yy")) ' format the date in to mmm-yy
                If Not .exists(Mmonth) Then 'If column C cells do not exist, load column E value in to dictionary using column C as item
                    .Item(Mmonth) = a(i, 14)
                Else
                    .Item(Mmonth) = .Item(Mmonth) + a(i, 14) 'If column C cells do exist, then add column E in to existing item
                End If
            End If
        Next
    End With
    
    With ws
        a = .Range("C7", .Cells(7, .Columns.Count).End(xlToLeft)) ' Load the required range in to array, named "a"
    End With
    
    ReDim Y(1 To 2, 1 To UBound(a, 2))
    
    With dic
        For i = 1 To UBound(a, 2) ' Loop through rows
            Mmonth = Trim(Format(a(1, i), "mmm yy")) ' format the date in to mmm-yy
            If .exists(Mmonth) Then 'If column C cells do exist then copy the the dictionary in to match column
                Y(1, i) = .Item(Mmonth)
            End If
        Next
    End With
    
    With ws
        'Process either Direct Activities, Enhancements, Indirect Activities, Overheads or PROJECTS for resize
        Select Case iOption
            
            'Direct Activities processing resize
            Case nUseAllDIR
            .Range("C9").Resize(1, i - 1) = Y() 'Result-load Y in to C8
            
            'Enhancements processing resize
            Case nUseAllEH
            .Range("C10").Resize(1, i - 1) = Y() 'Result-load Y in to C8
            
            'Indirect Activities processing resize
            Case nUseAllIND
            .Range("C11").Resize(1, i - 1) = Y() 'Result-load Y in to C8
            
            'Overheads processing resize
            Case nUseAllOVH
            .Range("C12").Resize(1, i - 1) = Y() 'Result-load Y in to C8
            
            'Projects processing resize
            Case nUseAllPRO
            .Range("C13").Resize(1, i - 1) = Y() 'Result-load Y in to C
        End Select
    End With
    End With
    End If
    Next rng
    Set dic = Nothing ' clear dic
End Sub

The code initially selects column B on the "All Data" sheet for unique values. The aim of this is to see whether the cell value matches a sheet name (already created), contained within the workbook. Then performs the following:

• When a match is found, the code then moves onto the first 'Select Case' statement and works through looking for the various criteria in the 'Case' sub routines i.e. Case nUseAllDIR, Case nUseAllEH, Case nUseAllIND, Case nUseAllOVH and Case nUseAllPRO.
  
  NB. For information, a(i, 1) = ws.Name is column B, (a(i, 6), "Consultancy & Innovation") = 0 is column G and (a(i, 8), "TM - DIR") > 0 is column I all on the "All Data" sheet.
  

• When these criteria are met the code then moves onto the following piece of code.
  
  

  If bColumnCIsConsultancyAndRequirements = True Then 'test if column C is "Consultancy & Requirements"
                  Mmonth = Trim(Format(a(i, 12), "mmm yy")) ' format the date in to mmm-yy
                  If Not .exists(Mmonth) Then 'If column C cells do not exist, load column E value in to dictionary using column C as item
                      .Item(Mmonth) = a(i, 14)
                  Else
                      .Item(Mmonth) = .Item(Mmonth) + a(i, 14) 'If column C cells do exist, then add column E in to existing item
                  End If
              End If

  
  Where it looks to see if firstly there is a value in column M on the [B]"All Data"[/B ]sheet, and where it does it then copies the associated value in column Q on the "All Data" sheet.

• Finally when these values are copied, the code moves onto the second 'Select Case' statement and pastes the value into the relevant cell.

This code works, but it is painfully slow, to the point it takes over an hour to extract, and I admit, that despite trying for over a week, I've not been able to make this any better.

I just wondered whether someone may be able to look at this please and offers some guidance on how to amend this.

I appreciate that this is a fairly lengthy and technical post, my apologies, but I thought it better to be as accurate with the process as possible. To help I've included a file here: https://www.dropbox.com/s/dc3b3dwr4n...0Home.xls?dl=0


To launch the macro which extracts the data to the individual sheets please click the button, but as I say this process takes a long time.

I did try to attach the file to the post, but it was over the file size limit.

Many thanks and kind regards

Chris

[mehmetcik]

You should have posted a spreadsheet.

Try these:-

1. Run my Optimise subroutine to speed up your macro:-

Sub Optimise()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
ActiveSheet.DisplayPageBreaks = False
End Sub

2. Replace

   bottomB = Range("B" & Rows.Count).End(xlUp).Row

with

   bottomB = Range("B65536").End(xlUp).Row

3. What is the point of:-

    
With ws
        a = .Range("C7", .Cells(7, .Columns.Count).End(xlToLeft)) ' Load the required range in to array, named "a"
End With

Replace with:

 a = ws.Range("C7", .Cells(7, .Columns.Count).End(xlToLeft))

4. What is the point of:-

                If a(i, 1) = ws.Name And InStr(a(i, 6), "Consultancy & Innovation") = 0 And _
                    InStr(a(i, 8), "TM - OVH") > 0 Then
                    
                    'Set the Column 'C' is 'Consultancy & Requirements' boolean value to true
                    'Conditions have been met for Indirect Activities
                    bColumnCIsConsultancyAndRequirements = True
                End If

Replace with:-

If a(i, 1) = ws.Name And InStr(a(i, 6), "Consultancy & Innovation") = 0 And InStr(a(i, 8), "TM - OVH") > 0 Then bColumnCIsConsultancyAndRequirements = True

[hobbiton73]

Hi @mehmetcik, thank you very much for taking the time to come back to me with this, it's greatly appreciated.

I made the amendments to my code as you kindly suggested, and it ran without error, but the problem is, is that this has made no difference to the time it takes to extract the information.

Many thanks and kind regards

Chris