PDA

View Full Version : [SOLVED] VBA Sum Records Which Match Monthly Column Heading



hobbiton73
09-01-2014, 11:30 PM
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 "All Data"[/B ]sheet, and where it does it then copies the associated value in column [B]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 (http://https://www.dropbox.com/s/dc3b3dwr4nfp7e2/Extract%20Test%20Home.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.


Now I did post this same question here: [URL]http://www.excelforum.com/excel-programming-vba-macros/1034277-vba-sum-records-which-match-monthly-column-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
09-02-2014, 05:12 AM
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
09-02-2014, 05:24 AM
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
09-02-2014, 06:25 AM
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
09-02-2014, 06:26 AM
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
09-02-2014, 08:14 AM
Hi @westconn1 I hope you are well.

As requested, please find a link to the file here:https://www.dropbox.com/s/vempq4dkm03qnxu/Extract%20Test%20Home%200209014.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
09-02-2014, 08:34 AM
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
09-02-2014, 10:17 AM
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
09-03-2014, 12:38 AM
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
09-10-2014, 07:17 AM
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