How to create uniform ranges?

[Jamshid]

Hi everybody,

I'm dealing with following problem: There are 3 data series in each
column (A, B, C). Column A represents distance (between 10 m and 100 m,
in other words randomly distributed). Question: Does anybody know how
it can be arranged by every 100 m (sum of continuous rows such as A1+A2+
etc. if the cell is equal to 100 then it should check next rows, even
several rows). B and C parameters which depend on A; B and C parameters
should be averaged accordingly to summed cells of A.

Example:

A B C
100 6.1 2.8
100 7.5 2.3
20 6.1 3.7
14 6.1 6.7
66 6.1 3.1
34 7 3.1
66 7 2.3


Desired Output:

A B C
100 6.1 2.8
100 7.5 2.3
100 6.1 4.5
(20+14+66) average(6.1,6.1,6.1) average(3.7,6.7,3.1)
......

......


I will appreciate any opinion, suggestion on how to create macro using
VBA excel for this problem.



Thanks a lot in advance,
Jamshid

 

[Lonnie M.]

Hi, I haven't tested this, but something along these lines should get
you pretty close to what you are looking for if I understand you
correctly. If not we can try again--Lonnie M.

Sub Test100()
Dim CountData&, X&, SumEnd&, C&, Aholder@, Bholder@, Cholder@
CountData = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
'SumEnd represents the row value to place 100 values
SumEnd = CountData + 1
For X = 1 To CountData
'Assuming A2 is the first data cell
If Aholder < 100 Then
Aholder = Aholder + Cells(X + 1, 1)
Bholder = Bholder + Cells(X + 1, 2)
Cholder = Cholder + Cells(X + 1, 3)
C = C + 1
End If
If Aholder >= 100 Then
SumEnd = SumEnd + 1
Cells(SumEnd, 1) = Aholder
Cells(SumEnd, 2) = Bholder / C
Cells(SumEnd, 3) = Cholder / C
Aholder = 0
Bholder = 0
Cholder = 0
C = 0
End If
Next X
End Sub

 

[Lonnie M.]

Hi, I haven't tested this but it should get you in the neighborhood:
'#########################################################
Sub Test100()
Dim CountData&, X&, SumEnd&, C&, Aholder@, Bholder@, Cholder@
CountData = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
'SumEnd represents the row value to place 100 values
SumEnd = CountData + 1
For X = 1 To CountData
'Assuming A2 is the first data cell
If Aholder < 100 Then
Aholder = Aholder + Cells(X + 1, 1)
Bholder = Bholder + Cells(X + 1, 2)
Cholder = Cholder + Cells(X + 1, 3)
C = C + 1
End If
If Aholder >= 100 Then
SumEnd = SumEnd + 1
Cells(SumEnd, 1) = Aholder
Cells(SumEnd, 2) = Bholder / C
Cells(SumEnd, 3) = Cholder / C
Aholder = 0
Bholder = 0
Cholder = 0
C = 0
End If
Next X
End Sub
'#########################################################
HTH--Lonnie M.

 

[Guest]

Hi

This copies the data over to columns E:F so that you can check it

Dim i As Long, r As Long, nr As Long
Sub copyData()
Dim tot As Integer, n As Integer
Dim x As Double, y As Double
Range("A2").Select
nr = ActiveCell.CurrentRegion.Rows.Count
For i = 2 To nr
n = 1
If Cells(i, 1) = 100 Then
Range(Cells(i, 5), Cells(i, 7)).Value = _
Range(Cells(i, 1), Cells(i, 3)).Value
ElseIf Cells(i, 1) < 100 Then

tot = Cells(i, 1).Value
x = Cells(i, 2).Value
y = Cells(i, 3).Value
Do While tot < 100
i = i + 1
n = n + 1
tot = tot + Cells(i, 1).Value
x = x + Cells(i, 2).Value
y = y + Cells(i, 3).Value
Loop
Cells(i, 5) = tot: Cells(i, 6) = x / n
Cells(i, 7) = y / n
tot = 0: x = 0: y = 0: n = 0
End If
Next i

End Sub


Regards
Peter

 

[Lonnie M.]

Hi Peter,
I have found that the following can get a little quirky when data has
been removed or formats have been applied:
ActiveCell.CurrentRegion.Rows.Count

This method provided by Tom Ogilvy will give you a more reliable rows
count:
ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row

Have a good one

 

[Jamshid Sodikov]

Thank you Peter for providing second solution,



Best Regards,
Jamshid

 

[Jamshid Sodikov]

Thanks a lot Lonnie, you nailed it. even some cases (few cases) greater
than 100 but for most of the cases 100. You gave very good idea.

Once again, thank you.

Best wishes ,
Jamshid