totalchaos
New Member
- Joined
- Jul 6, 2012
- Messages
- 40
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:
<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!
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!