Within the same workbook, I want to summarize
by Project the "Detail" worksheet into the "Summary" worksheet.
I probably have a range syntax error, but I cannot detect it.
I have an Overflow error and the Countif that drives the loop is at
zero.
..
I could easily do it with a pivot table, that is not what I want.
I want to process it with VBA as I have attempted below.
Help appreciated.
J.P.
.............................................
Source : "Detail" worksheet
A B C D
E
1. Date Project Activity Force Hours
2. 8/27/2010 Project C T 5 300
3. 8/29/2010 Project C U 10 500
4. 8/26/2010 Project A L 1 50
5. 8/28/2010 Project A M 11 550
6. 8/23/2010 Project K V 4 200
7. 8/25/2010 Project K X 6 300
...........................................
Destination : "Destination" worksheet
Project Force Hours
Project A 12 600
Project C 15 800
Project K 10 500
...........................................
Sub ProjectSummary()
Dim WB As Workbook
Dim SH1 As Worksheet
Dim SH2 As Worksheet
Dim MyPath, Line As String
Dim DestCell As Range
Dim i As Integer: Dim j As Integer: Dim k As Integer
Dim RngD As Range
Dim RngE As Range
Dim RngB As Range
On Error GoTo ErrorCatch
MyPath = "C:\1-Work\TestData\"
Set WB = Workbooks.Open(MyPath & "Omega.xls")
Set SH1 = WB.Worksheets("Detail")
Set SH2 = WB.Worksheets("Summary")
Set DestCell = SH2.Range("A1")
ActiveWorkbook.Sheets("Detail").Select
DestCell = "Project"
DestCell.Offset(0, 1) = "Force"
DestCell.Offset(0, 2) = "Hours"
'------------------------------------------
'Sort rows by Project
SH1.Range("A2").CurrentRegion.Sort Key1:=SH1.Range("B2"),
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1,
MatchCase:=False, Orientation:=xlTopToBottom
'=================== Probable Error Area =========================
Set RngD = Range(Cells(1, "D"), Cells(Rows.Count, "D").End(xlUp))
Set RngE = Range(Cells(1, "E"), Cells(Rows.Count, "E").End(xlUp))
Set RngB = Range(Cells(1, "B"), Cells(Rows.Count, "B").End(xlUp))
' Calculate Sum for Project
Line = "Do While"
Do While i <= Worksheets("Detail").Range("A100").End(xlUp).Row
j = Application.CountIf(RngB, Cells(i, "B"))
Line = j & " Summary Col. A " 'Error is there : Overflow message
and J = 0
'================================================= ======
Worksheets("Summary").Cells(k, "A") = Cells(i, "B")
Worksheets("Summary").Cells(k, "B") = Application.SumIf(RngB,
Cells(i, "B"), RngD)
Worksheets("Summary").Cells(k, "C") = Application.SumIf(RngB,
Cells(i, "B"), RngE)
k = k + 1: i = i + j
Loop
Exit Sub
ErrorCatch:
MsgBox "ErrorCatch Line : " & Line & " " & Err.Description
Resume Next
End Sub