Clean up help
Thanks Guys. I will give it a try
Andy
"JK" wrote:
Here's a code to do the trick (maybe not the cleanest/clearest but
still...):
***
Sub CleanUp()
Dim i As Integer, j As Integer
Dim intRows As Integer, intCols As Integer
Dim rngCount As Range
Dim tot()
intCols = 7
ReDim tot(10, intCols)
j = 0
Set rngCount = Range("A:A")
intRows = WorksheetFunction.CountA(rngCount) + 1
For i = 2 To intRows
If Cells(i - 1, 1) = Cells(i, 1) Then
If Cells(i - 1, 4) = Cells(i, 4) Then
tot(j, 1) = tot(j, 1) + Cells(i - 1, 2)
tot(j, 4) = tot(j, 4) + Cells(i - 1, 5)
tot(j, 5) = tot(j, 5) + Cells(i - 1, 6)
tot(j, 6) = tot(j, 6) + Cells(i - 1, 7)
tot(j, 7) = tot(j, 7) + Cells(i - 1, 8)
Else
tot(j, 0) = Cells(i - 1, 1)
tot(j, 1) = tot(j, 1) + Cells(i - 1, 2)
tot(j, 4) = tot(j, 4) + Cells(i - 1, 5)
tot(j, 5) = tot(j, 5) + Cells(i - 1, 6)
tot(j, 6) = tot(j, 6) + Cells(i - 1, 7)
tot(j, 7) = tot(j, 7) + Cells(i - 1, 8)
tot(j, 2) = tot(j, 4) / tot(j, 1)
tot(j, 3) = Cells(i - 1, 4)
j = j + 1
End If
Else
tot(j, 0) = Cells(i - 1, 1)
tot(j, 1) = tot(j, 1) + Cells(i - 1, 2)
tot(j, 4) = tot(j, 4) + Cells(i - 1, 5)
tot(j, 5) = tot(j, 5) + Cells(i - 1, 6)
tot(j, 6) = tot(j, 6) + Cells(i - 1, 7)
tot(j, 7) = tot(j, 7) + Cells(i - 1, 8)
tot(j, 2) = tot(j, 4) / tot(j, 1)
tot(j, 3) = Cells(i - 1, 4)
j = j + 1
End If
Next i
For i = 0 To UBound(tot()) - 1
For j = 0 To intCols
Cells(i + intRows + 3, j + 1) = tot(i, j)
Next j
Next i
End Sub
***
btw. you have date in either the rows 14-16 wrong or in 17 and summary
;)
regs,
JK
|