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 pieces of 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/dc3b3dwr4nfp7e2/Extract%20Test%20Home.xls?dl=0[/URL]

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.


Now I did post this same question here: http://www.excelforum.com/excel-prog...n-heading.html ansd although I was fortunate enough to receive a reply, unfortunately I still have the same issue.


Many thanks and kind regards
Chris

[westconn1]

can you post some sample of desired results, for checking results, so as to remove the need to run existing code to get results

your select case with multiple criteria would be slow, i am sure there would be much faster methods, specifically ADO, but i am unsure of how the results should be determined

[snb]

I'd say :

Sub M_snb()
   for j= 1 to 5
     for each it in Sheets("All Data").range("B8").currentregion
        If a(i, 1) = ws.Name And InStr(a(i, 6), "Consultancy & Innovation") = 0 And InStr(a(i, 8), choose(j,"TM - DIR",Enhancements","TM - ID", etc) > 0 Then
     next
   next
end sub

[hobbiton73]

HI @snb, thank you for taking the time to come back to me with this.

Forgive me for being a little stupid, but could you tell me pleas which part of the code you wish me to chnage?

I've incorporated the code snippet you kindly provided where I thought it would be, but I receive a syntax error.

Many thanks and kind regards

Chris

[hobbiton73]

Hi @westconn1, thank you very much for taking the time to reply to my post. I will amend the test file I originally sent and re-issue on my return home.

Many thanks and kind regards

Chirs

[hobbiton73]

Hi @westconn1 I hope you are well.

As requested, please find a link to the file here:https://www.dropbox.com/s/vempq4dkm0...09014.xls?dl=0 . I've run the code and created a new set of sheets which displays the relevant data and re-named them with a "1" at the end, so if you want to run the code from scratch, please click the 'Launch' button which will create a new set of sheets and extract the data, but it does take some time.

Once again many thanks for taking the time to contact me.

Kind Regards

Chris

[snb]

My suggestion was only meant to indicate how you could reduce your code to a very simple one. It's not running code.
Please post your sample workbook in this forum.
If your file will be removed from dropbox this thread isn't hardly worth reading for anyone with the same kind of question.
Consider this forum as a kind of 'Fundgrube' for 'generations to come'.

[hobbiton73]

Hi @snb, thank you for coming back to me with this, and my sincere apologies for the lack of thought for what, as you say, future generations.

Please find a very cut down version of my test file. I have run the macro, creating the sheets and extracting the data. I have added a "1" to each sheet name which will then, if you wish allow you to run the macro for yourself.

Many thanks and kind regards

Chris

[snb]

I removed all ' 1' after the sheetnames
If you change the 'enhancement' project names in column I i.e starting with 'enhancement..." we can reduce the code with one more line.

The only code you need (making the progressbar redundant)

Sub M_snb()
    sn = Sheets("all data").Cells(7, 2).CurrentRegion
    ReDim sp(5, 11)
    
    With CreateObject("scripting.dictionary")
      For Each sh In Sheets
         If InStr("All DataLaunch Sheet", sh.Name) = 0 Then .Item(sh.Name) = sp
      Next
      
      For j = 2 To UBound(sn)
         st = .Item(sn(j, 1))
         x = InStr("DhIOc", Mid(sn(j, 8), 6, 1))
         If x = 0 Then x = 2
         y = (DatePart("m", sn(j, 12)) + 8) Mod 12
         st(x, y) = st(x, y) + sn(j, 16)
         .Item(sn(j, 1)) = st
      Next
      
      For Each it In .keys
        Sheets(it).Range("C8:N13") = .Item(it)
      Next
    End With
End Sub

[hobbiton73]

Hi @snb, thank you for coming back to me with this and my sincere apologies for not replying sooner.

I an confirm that the code works fine.

All the best and kind regards

Chris