rainflow (P/V Diff)

rainflow.bas

Option Explicit

Sub rainflow()
    Dim mem_arr() As Variant
    Dim peakdata() As Variant
    Dim ex_data() As Variant
    Dim ws As Worksheet
    Dim i As Long
    Dim j As Long
    Dim k As Long
               
    Set ws = ActiveSheet
    
    ' ================ データ読み込み&ピーク点抽出 =====================
    Call peak_count(peakdata())
    
    ' ================ P/V差法によるレインフロー法 =====================
    ReDim mem_arr(1, 0)
    mem_arr(0, 0) = peakdata(1, 1)
    mem_arr(1, 0) = peakdata(2, 1)
    i = 0
    k = -1
    ' 小ループ除去の処理
    For j = 2 To UBound(peakdata, 2)
        i = UBound(mem_arr, 2) + 1
        ReDim Preserve mem_arr(1, i)
        mem_arr(0, i) = peakdata(1, j)
        mem_arr(1, i) = peakdata(2, j)
        While i >= 2
            If Abs(mem_arr(1, i - 2) - mem_arr(1, i - 1)) > Abs(mem_arr(1, i - 1) - mem_arr(1, i)) Then
                GoTo Continue
            ElseIf i = 2 Then
                k = k + 1
                ReDim Preserve ex_data(4, k)
                ex_data(0, k) = Abs(mem_arr(1, 0) - mem_arr(1, 1))
                ex_data(1, k) = 0.5 * (mem_arr(1, 0) + mem_arr(1, 1))
                ex_data(2, k) = 0.5
                ex_data(3, k) = mem_arr(0, 0)
                ex_data(4, k) = mem_arr(0, 1)
                
                mem_arr(0, 0) = mem_arr(0, 1)
                mem_arr(1, 0) = mem_arr(1, 1)
                mem_arr(0, 1) = mem_arr(0, 2)
                mem_arr(1, 1) = mem_arr(1, 2)
                ReDim Preserve mem_arr(1, 1)
                i = 1
            Else
                k = k + 1
                ReDim Preserve ex_data(4, k)
                ex_data(0, k) = Abs(mem_arr(1, i - 2) - mem_arr(1, i - 1))
                ex_data(1, k) = 0.5 * (mem_arr(1, i - 2) + mem_arr(1, i - 1))
                ex_data(2, k) = 1#
                ex_data(3, k) = mem_arr(0, i - 2)
                ex_data(4, k) = mem_arr(0, i - 1)
                
                mem_arr(0, i - 2) = mem_arr(0, i)
                mem_arr(1, i - 2) = mem_arr(1, i)
                ReDim Preserve mem_arr(1, i - 2)
                i = i - 2
            End If
        Wend
Continue:
    Next j
    ' 小ループしきった波形の処理
    For i = 0 To UBound(mem_arr, 2) - 1
        k = k + 1
        ReDim Preserve ex_data(4, k)
        ex_data(0, k) = Abs(mem_arr(1, i + 1) - mem_arr(1, i))
        ex_data(1, k) = 0.5 * (mem_arr(1, i + 1) + mem_arr(1, i))
        ex_data(2, k) = 0.5
        ex_data(3, k) = mem_arr(0, i)
        ex_data(4, k) = mem_arr(0, i + 1)
    Next i
    MsgBox ("レインフロー法の計算が終了しました。結果出力のためしばらく画面が止まります。")
    
    ' ================ データ出力 =====================
    Application.ScreenUpdating = False
    
    For i = LBound(ex_data, 1) To UBound(ex_data, 1)
        For j = LBound(ex_data, 2) To UBound(ex_data, 2)
            ws.Cells(j + 2, i + 4).Value = ex_data(i, j)
        Next j
    Next i
    ws.Cells(1, 4).Value = "Range(Full)"
    ws.Cells(1, 5).Value = "Average"
    ws.Cells(1, 6).Value = "Count(Loop)"
    ws.Cells(1, 7).Value = "i_start"
    ws.Cells(1, 8).Value = "i_end"
    
    For j = 1 To UBound(peakdata, 2)
        ws.Cells(j + 1, 10).Value = peakdata(1, j)
        ws.Cells(j + 1, 11).Value = peakdata(2, j)
    Next j
    ws.Cells(1, 10).Value = "i_peak"
    ws.Cells(1, 11).Value = "Peak"
    
    Application.ScreenUpdating = True
    MsgBox ("レインフロー法による計算結果の出力が完了しました。")
End Sub

Sub peak_count(ByRef peakdata() As Variant)
    Dim data() As Variant
    Dim ws As Worksheet
    Dim FinalRow As Long, FinalRowFull as Long
    Dim StartRow As Long, StartCol As Long
    
    Dim i_last As Long
    Dim i As Long
    Dim i_next As Long
    Dim diff_d_last As Double
    Dim diff_d_next As Double
    Set ws = ActiveSheet
    
    ' データを読み込む データ開始位置はA1前提
    ' A列は時系列ラベル（時間、ナンバー）、B列はレインフローしたいデータ
    With ws.UsedRange
        FinalRowFull = .Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        FinalRow = .Find(What:="*", After:=ws.Cells(FinalRowFull, 2), LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    End With
    
    Debug.Print "FinalRowFull = " & FinalRowFull & ", FinalRow = " & FinalRow
    
    StartRow = 1
    StartCol = 1
    
    data = ws.Cells(StartRow, StartCol).Resize(FinalRow, StartCol + 1).Value
    
    ' ピーク点のみ抽出
    ReDim peakdata(2, 1)
    peakdata(1, 1) = data(1, 1)
    ' peakdata(1, 1) = 0
    peakdata(2, 1) = data(1, 2)
    Debug.Print "data():" & UBound(data, 1) & " x " & UBound(data, 2)
    Debug.Print "peakdata No. " & UBound(peakdata, 2) & " : " & peakdata(1, UBound(peakdata, 2)) & " , " & peakdata(2, UBound(peakdata, 2))
    
    i_last = 1
    i = i_last + 1
    diff_d_last = data(i_last + 1, 2) - data(i_last, 2)
    
    For i_next = i + 1 To FinalRow
        If data(i_next, 2) = data(i, 2) Then
            GoTo Continue
        Else
            diff_d_next = data(i_next, 2) - data(i, 2)
            If diff_d_next * diff_d_last < 0 Then
                ReDim Preserve peakdata(2, UBound(peakdata, 2) + 1)
                peakdata(1, UBound(peakdata, 2)) = data(i, 1)
                ' peakdata(1, UBound(peakdata, 2)) = i - 1
                peakdata(2, UBound(peakdata, 2)) = data(i, 2)
                Debug.Print "peakdata No. " & UBound(peakdata, 2) & " : " & peakdata(1, UBound(peakdata, 2)) & " , " & peakdata(2, UBound(peakdata, 2))
            End If
            i_last = i
            i = i_next
            diff_d_last = diff_d_next
        End If
Continue:
    Next
    ' 最後尾のデータを追加
    ReDim Preserve peakdata(2, UBound(peakdata, 2) + 1)
    peakdata(1, UBound(peakdata, 2)) = data(i, 1)
    ' peakdata(1, UBound(peakdata, 2)) = i - 1
    peakdata(2, UBound(peakdata, 2)) = data(i, 2)
    Debug.Print "peakdata No. " & UBound(peakdata, 2) & " : " & peakdata(1, UBound(peakdata, 2)) & " , " & peakdata(2, UBound(peakdata, 2))
    Debug.Print "Peak Count FIN"
End Sub