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

Hello !

I notice two things:

An error of syntax:
replace Cells(1, "B") by Cells(1, 2)
replace Cells(1, "C") by Cells(1, 3)
replace Cells(1, "D") by Cells(1, 4)
replace Cells(1, "E") by Cells(1, 5)

and a logical one:
before using a loop, one should initialize the variable used for staying in
the loop or stopping it.
In your case, i and k are initialized to zero (default value)
You should write:

i = 2
k = 2
Do While i <= Worksheets("Detail").Range("A100").End(xlUp).Row

The modified code:

Sub ProjectSummary()
Dim WB As Workbook
Dim SH1 As Worksheet, SH2 As Worksheet
Dim MyPath, Line As String
Dim DestCell As Range
Dim i As Integer, j As Integer, k As Integer
Dim RngD As Range, RngE As Range, RngB As Range

On Error GoTo ErrorCatch
MyPath = "C:\1-Work\TestData\"
Set WB = ThisWorkbook ' 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

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
i = 2
k = 2
Do While i <= Worksheets("Detail").Range("A100").End(xlUp).Row
j = Application.CountIf(RngB, Cells(i, 2))
Line = j & " Summary Col. A "
Worksheets("Summary").Cells(k, 1) = Cells(i, 2)
Worksheets("Summary").Cells(k, 2) = Application.SumIf(RngB, _
Cells(i, 2), RngD)
Worksheets("Summary").Cells(k, 3) = Application.SumIf(RngB, _
Cells(i, 2), RngE)
k = k + 1: i = i + j
Loop
Exit Sub

ErrorCatch:
MsgBox Err.Description
End Sub


Does it help ?

Errata:

Replace the line:
Set WB = ThisWorkbook ' Workbooks.Open(MyPath & "Omega.xls")
with your initial line:
Set WB = Workbooks.Open(MyPath & "Omega.xls")

And if you want your macro run more than once, you could erase the old
results before the new calculation. Just insert this line:
Range(DestCell, DestCell.End(xlDown).Resize(, 3)).ClearContents
after the line:
Set DestCell = SH2.Range("A1")











"Charabeuh" a écrit dans le message de groupe de
discussion : ...
Hello !

I notice two things:

An error of syntax:
replace Cells(1, "B") by Cells(1, 2)
replace Cells(1, "C") by Cells(1, 3)
replace Cells(1, "D") by Cells(1, 4)
replace Cells(1, "E") by Cells(1, 5)

and a logical one:
before using a loop, one should initialize the variable used for staying
in the loop or stopping it.
In your case, i and k are initialized to zero (default value)
You should write:

i = 2
k = 2
Do While i <= Worksheets("Detail").Range("A100").End(xlUp).Row

The modified code:

Sub ProjectSummary()
Dim WB As Workbook
Dim SH1 As Worksheet, SH2 As Worksheet
Dim MyPath, Line As String
Dim DestCell As Range
Dim i As Integer, j As Integer, k As Integer
Dim RngD As Range, RngE As Range, RngB As Range

On Error GoTo ErrorCatch
MyPath = "C:\1-Work\TestData\"
Set WB = ThisWorkbook ' 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

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
i = 2
k = 2
Do While i <= Worksheets("Detail").Range("A100").End(xlUp).Row
j = Application.CountIf(RngB, Cells(i, 2))
Line = j & " Summary Col. A "
Worksheets("Summary").Cells(k, 1) = Cells(i, 2)
Worksheets("Summary").Cells(k, 2) = Application.SumIf(RngB, _
Cells(i, 2), RngD)
Worksheets("Summary").Cells(k, 3) = Application.SumIf(RngB, _
Cells(i, 2), RngE)
k = k + 1: i = i + j
Loop
Exit Sub

ErrorCatch:
MsgBox Err.Description
End Sub


Does it help ?

Sorry, I still have the Overflow error.
However, I agree with you for the i & k not being initialized,
after I posted my code, I deleted unnecessary comments,
and that line was deleted by mistake.
I am still scratching my head, because I have used that code before.
J.P.

Hello !

It is very strange.
By me, with your code and with the initialization of i and k and without any
other change, your code is working perfectly. Did you run your code step by
step and check before executing the line where the error occurs all the
values of the different variables (i,j,k;Cells(i, "B")...etc) ?



"u473" a écrit dans le message de groupe de discussion :
...
Sorry, I still have the Overflow error.
However, I agree with you for the i & k not being initialized,
after I posted my code, I deleted unnecessary comments,
and that line was deleted by mistake.
I am still scratching my head, because I have used that code before.
J.P.

Thank you for your response.
I am still debugging step by step.

After testing, this is what I have found do far :

1. The execution of this code is launched from : C:\1-Work\TestData
\P1\ReOrg.xls
2. Everything works fine thru currentregion.sort
3. However, when I try to test the value of Cells(Rows.Count,
"D").End(xlUp) for RngD
I find that it is counting rows in ReOrg book instead of SH1
4. So far my various attempts to activate SH1 or
WB.Worksheets("Detail") have been unsuccesful
I do not understand why just before the Set RngD, the sorting
works well in the "Detail" sheet
and then it switches reference to ReOrg book.
I understand I am doing something wrong in my referencing, but I
have not found where yet.