Find alternative to using nested loops for subtotalling data

[totalchaos]

I currently have data (below) that I sort by date, then job, then trade and then shift. For each date, job, trade and shift, I must provide subtotals and output the results to a separate sheet.

The code I currently use has nested do..loops which navigates the data, fills an array and writes to a separate sheet. The code (below) is the gist of what I have. The actual code is so complex to look at it gives me a headache and is hard to manage.

I'm looking for an alternative to the approach I've taken. I researched using autofilter. Unfortunately, from I can tell, I cannot get the list of unique values inside each filter which I would use to store in an array and then loop through and autofilter the specific values in the 4 fields I listed in the first paragraph. I'd then use the worksheetfunction.subtotal to get my subtotals. If anybody knows how to do this, it would be greatly helpful to me to simplify my code and possibly provide some performance efficiency. If it's not possible to use autofilter, any other suggestions would be greatly appreciated to simplify my code and improve the efficiency since my actual list is much larger. I'm using excel 2007 and 2010 on different computers.

Here is the data:

Excel 2007
	A	B	C	D	E	F	G	H	I
1	Line#	Employee	Job	Trade	Code	Extra #	Shift	Work Date	Hours
2	1	1	1201	Carpenter	A	0	1	7/19/2012	4
3	2	1	1201	Carpenter	B	0	1	7/19/2012	4
4	3	2	1201	Plumber	A	1	2	7/18/2012	4
5	4	2	1201	Plumber	A	2	1	7/18/2012	3
6	5	2	1201	Plumber	A	0	1	7/18/2012	1
7	6	3	1201	Electrician	B	1	2	7/19/2012	3
8	7	3	1202	Electrician	B	0	2	7/19/2012	5
9	8	4	1201	Electrician	B	0	1	7/19/2012	8
10	9	4	1201	Electrician	A	0	1	7/18/2012	8
11	10	5	1202	Carpenter	A	0	1	7/19/2012	8
12	11	6	1201	Electrician	A	1	1	7/19/2012	2
13	12	6	1201	Electrician	A	0	1	7/19/2012	3
14	13	6	1201	Electrician	B	0	1	7/19/2012	2
15	14	6	1201	Electrician	B	1	1	7/19/2012	1
16	15	7	1202	Plumber	A	1	2	7/19/2012	3
17	16	7	1202	Plumber	A	0	2	7/19/2012	2
18	17	7	1202	Plumber	A	2	2	7/19/2012	4
19	18	8	1202	Carpenter	A	1	2	7/18/2012	2
20	19	8	1201	Carpenter	B	1	2	7/18/2012	6
21	20	9	1202	Plumber	A	1	1	7/18/2012	4
22	21	9	1202	Plumber	A	0	1	7/18/2012	4
23	22	10	1202	Carpenter	A	1	1	7/18/2012	2
24	23	10	1202	Carpenter	B	2	1	7/18/2012	1
25	24	10	1202	Carpenter	B	0	1	7/18/2012	3
26	25	10	1201	Carpenter	B	0	1	7/18/2012	2
Sheet1

<colgroup><col style="width: 48pt;" span="10" width="64"> <tbody>
</tbody>

Here is the code I currently use in a standard module:

Option Explicit
Dim wsSrce As Worksheet, rng As Range, sngHours As Single, strWrkDate As String, _
strJobNum As String, strTrade As String, strShift As String, Cntr As Long, _
arr() As Variant, i As Integer

Private Sub WorkReport()
Set wsSrce = ActiveWorkbook.Worksheets("Sheet1")
Set rng = wsSrce.Range("A1:I26")
'Sort by workdate, job, trade, shift
With wsSrce.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("H2:H26"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("C2:C26"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("D2:D26"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("G2:G26"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rng
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'sum hours for each unique workdate, job, trade, shift combination
With wsSrce
Cntr = 1
Do Until IsEmpty(.Cells(Cntr, 1)) '1
Cntr = Cntr + 1
strWrkDate = .Cells(Cntr, 8)
Do While .Cells(Cntr, 8) = strWrkDate '2
strJobNum = .Cells(Cntr, 3)
Do While .Cells(Cntr, 8) = strWrkDate And .Cells(Cntr, 3) = strJobNum '3
strTrade = .Cells(Cntr, 4)
Do While .Cells(Cntr, 8) = strWrkDate And .Cells(Cntr, 3) = strJobNum And .Cells(Cntr, 4) = strTrade '4
strShift = .Cells(Cntr, 7)
Do While .Cells(Cntr, 8) = strWrkDate And .Cells(Cntr, 3) = strJobNum And .Cells(Cntr, 4) = strTrade And .Cells(Cntr, 7) = strShift '5
sngHours = sngHours + .Cells(Cntr, 9)
Cntr = Cntr + 1
Loop
FillArray
sngHours = 0
Loop
Loop
Loop
Loop
End With
WriteArray
'sort back to original order
With wsSrce.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A2:A26"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rng
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Private Sub FillArray()
i = i + 1
ReDim Preserve arr(1 To 5, 1 To i)
arr(1, i) = strWrkDate
arr(2, i) = strJobNum
arr(3, i) = strTrade
arr(4, i) = strShift
arr(5, i) = sngHours
End Sub
Private Sub WriteArray()
Dim a As Integer, wsTrgt As Worksheet, lngLR As Long
Set wsTrgt = ActiveWorkbook.Worksheets("Sheet2")
For a = 1 To UBound(arr, 2)
With wsTrgt
lngLR = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(lngLR, 1) = arr(1, a)
.Cells(lngLR, 2) = arr(2, a)
.Cells(lngLR, 3) = arr(3, a)
.Cells(lngLR, 4) = arr(4, a)
.Cells(lngLR, 5) = arr(5, a)
End With
Next a
Erase arr
End Sub

Any help is greatly appreciated!

 

[memar_one]

By the way, try:

=SUMPRODUCT(--(Sheet1!$H$2:$H$1000=$A3), --(Sheet1!$C$2:$C$1000=$B3), --(Sheet1!$D$2:$D$1000=$C3), --(Sheet1!$G$2:$G$1000=VALUE(RIGHT(D$2, 1))), Sheet1!$I$2:$I$1000)

Put this in sheet 2 in cell D3 and copy through cells D3:G12.

I tried to follow the format of your above example result, and this will add up hours by date and job and trade and shift, but not by code.