Solved: Rainflow Three-Point Algorithm

[Louis]

Hello,

I am new to the board and I am hoping some one can help me out. I am trying to write a Three point rainflow counting algorithm for stress analysis in Excel. Everything is working perfectly except for the three- point algorithm.

What I am trying to do is look at the data posted in column A.

Then If the Difference of abs(A1-A2) <= abs(A3-A2) then
print abs(A1-A2) in Column 8 and then Copy The data from A3 to the end of the row and move it up two spaces and repeat the process until a4 is empty.

The amount of data point will very each time so I can't use a specified range in my code. It has to be something like 1 to endrow where endrow is the last value in the column, which I think is the probelm I am running into because endrow changes everytime.

[SamT]

Hello,

I am new to the board and I am hoping some one can help me out. I am trying to write a Three point rainflow counting algorithm for stress analysis in Excel. Everything is working perfectly except for the three- point algorithm.

What I am trying to do is look at the data posted in column A.

Then If the Difference of abs(A1-A2) <= abs(A3-A2) then
print abs(A1-A2) in Column 8 and then Copy The data from A3 to the end of the row and move it up two spaces and repeat the process until a4 is empty.

The amount of data point will very each time so I can't use a specified range in my code. It has to be something like 1 to endrow where endrow is the last value in the column, which I think is the probelm I am running into because endrow changes everytime.
Hello Louis, Let me be the first to welcome you to VBAX.

Lemme tellya, you engineers are something else, expecting a lowly coder to understand Stress Analysis and why annual precipitation is important therein.

:rotlaugh:

Ok, humor aside...

"endrow" is usually refered to as LastRow (with Caps,) in VBA and there are many ways to find it.

If you know that there is always going to be at least two rows with data AND that there will never be a gap in the data, the easiest method is one of two code strings. Change the Range to use a column that has data in all Cells.

Returns the Cell that is the last cell with data:Dim LastRow as Range
Set LastRow = Range("A1").End(xlDown) Returns the Row number of the last Cell with dataDim LastRow as Long
LastRow = Range("A1").End(xlDown).Row

If you can't guarantee that there are no gaps in the data, or even that there is any data at all, start from the bottom and look up.

Returns the last used CellSet LastRow = Cells(Rows.Count, 1).End(xlUp) Returns the Row number of the last Cell with dataLastRow = Cells(Rows.Count, 1).End(xlUp).Row
To get first empty Cell, you must Offset the LastRow Range or add 1 to the LastRow Row number.

The same method works for the LastCol and with the same conditions.

To return the last used column numberLastCol = Range("A1").End(xlToRight).ColumnandLastCol = Cells(1, Columns.Count).End(xlToLeft.Column

------------------------------------------------------------------------------------------------------------------

Since the last data column is "G" or less, we can define the Row 3 data Range withDim DataRng As Range
Set DataRng = Range("A3:G3") We will define the result cell, (where to print abs(A1-A2), as Dim RCol As Long
Dim RRow As Long
RCols = 8
RRow = 1 'Adjust to actual starting row number in Column "H"
'Example usage
Cells(RRow, RCol) = abs(A1-A2)
RRow = RRow + 1 'Increment the Row number

Reading your description of the problem, it sounds like you want to move the DataRng to Row 1 and move Row 4 to Row 3. It also sounds like you want to leave row 3 alone after the last computation.

Sub SamT()
Dim DataRng As Range
Dim RCol As Long
Dim RRow As Long
RCols = 8
Do 'Start the process loop
Set DataRng = Range("A3:G3")
If Abs(Range("A1") - Range("A2")) <= Abs(Range("A3") - Range("A2")) Then
Cells(RRow, RCol) = Abs(Range("A1") - Range("A2"))
RRow = RRow + 1 'Increment the Results Cell Row number
End If
DataRng.Copy Range("A1")
DataRng.Delete (xlShiftUp)
Loop While Range("A4") <> ""
End Sub

If you want to RTM in VBA, place the cursor in the word you want to read about and press F1.

ps: That ain't tested :devil2:

[Louis]

Just to clarify here is what I would like the code to do.

Lets say I have data points

A1
A2
A3
A4
A6
A7
A8
A9
A10

then I need say

If abs(a4-a3) >= abs(a3-a2) then
print abs(a3-a2) in column 8 then
delete a3 and a2 and move rest of data up and do look again.

second time it goes around
now a4=a2
a5=a3
ect.
so if I use the new points it
If abs(a4-a3) >= abs(a3-a2) then
print abs(a3-a2) in next row of colum 8
delete a3 and a2
and move other points up.

Thanks for the help

[p45cal]

what do you want to happen if If abs(a4-a3) < abs(a3-a2)?

[Louis]

what do you want to happen if If abs(a4-a3) < abs(a3-a2)?

Move the data points up so that a2=a3 ......

[p45cal]

try:Sub blah()
Do Until Range("A4").Value = ""
' text from question:If abs(a4-a3) >= abs(a3-a2) then print abs(a3-a2) in column 8 then delete a3 and a2 and move rest of data up and do look again.
'Range("a3:a4").Select
'Range("a2:a3").Select
'MsgBox "abs A4-A3 = " & Abs(Range("a4") - Range("a3")) & vbLf & ">=" & vbLf & "abs A3-A2 = " & Abs(Range("a3") - Range("a2"))
If Abs(Range("a4") - Range("a3")) >= Abs(Range("a3") - Range("a2")) Then
Cells(Rows.Count, "H").End(xlUp).Offset(1) = Abs(Range("a3") - Range("a2"))
Range("A2:A3").Delete shift:=xlUp
Else 'Move the data points up so that a2=a3 ......
Range("A2").Delete shift:=xlUp
End If
Loop
End Sub
There are some commented-out lines that you can re-include to help debug what it's doing, especially if you step through the code with F8.

[SamT]

Just to clarify here is what I would like the code to do.

Lets say I have data points

A1
A2
A3
A4
A6
A7
A8
A9
A10

then I need say

If abs(a4-a3) >= abs(a3-a2) then
print abs(a3-a2) in column 8 then
delete a3 and a2 and move rest of data up and do look again.

second time it goes around
now a4=a2
a5=a3
ect.
so if I use the new points it
If abs(a4-a3) >= abs(a3-a2) then
print abs(a3-a2) in next row of colum 8
delete a3 and a2
and move other points up.

Thanks for the help

you're welcome.

[Louis]

try:Sub blah()
Set cll = Range("A1")
Do Until Range("A4").Value = ""
' text from question:If abs(a4-a3) >= abs(a3-a2) then print abs(a3-a2) in column 8 then delete a3 and a2 and move rest of data up and do look again.
'Range("a3:a4").Select
'Range("a2:a3").Select
'MsgBox "abs A4-A3 = " & Abs(Range("a4") - Range("a3")) & vbLf & ">=" & vbLf & "abs A3-A2 = " & Abs(Range("a3") - Range("a2"))
If Abs(Range("a4") - Range("a3")) >= Abs(Range("a3") - Range("a2")) Then
Cells(Rows.Count, "H").End(xlUp).Offset(1) = Abs(Range("a3") - Range("a2"))
Range("A2:A3").Delete shift:=xlUp
Else 'Move the data points up so that a2=a3 ......
Range("A2").Delete shift:=xlUp
End If
Loop
End Sub
There are some commented-out lines that you can re-include to help debug what it's doing, especially if you step through the code with F8.

Perfect! Does exactly what I needed it to do. Thanks!

[Louis]

any idea why I am getting an overflow error with this code? It worked fine yesterday and this morning it is giving me an overflow error message.

Sub three_point()
Set c11 = Range("A1")
Dim i As Integer
i = 2
p = 2

Do Until Range("A2") = ""
If Abs(Cells(i, 1).Value - Cells(i + 1, 1).Value) < Abs(Cells(i + 1, 1).Value - Cells(i + 2, 1).Value) Then
Cells(p, 8).Value = Abs(Cells(i, 1).Value - Cells(i + 1, 1).Value)
Cells(p, 9).Value = (Cells(i, 1).Value + Cells(i + 1, 1).Value) / 2
Cells(i + 1, 1).Delete shift:=xlUp
Cells(i, 1).Delete shift:=xlUp
i = 2
p = p + 1
Else
i = i + 1
End If
Loop
End Sub

sorry for the code in the post. I was trying to use pastebin but I can't post links yet.
Louis

[p45cal]

The overflow is because i is going up beyond the integer upper limit (32766).
However, that's probably not the problem; is A2 ever getting to be ""? If not then it's looping forever.

[Louis]

Thanks for the help. I forgot to change it from A2 to A3 when I added text in A1 and started the data in A2. Stupid mistake.

Thanks for the help p45cal