[[20210119192611]]　『VBAで2峰のピークトップ間の最低値を抜き出したい』（GGr）　ページの最後に飛ぶ

『VBAで2峰のピークトップ間の最低値を抜き出したい。』（GGr）

グラフを書くと2峰性のピークを示す数値が並んでいて、
その2ピークトップのセル間の最低値を抜き出して、
あるセルに書き出したいのですが、VBAで記載できないでしょうか。
例えば下記を一桁の数字が行に並んでいるとして、
グラフを書くと左ピークは7で右ピークは8です。
そのセル間の最低値2をどこかのセルに書き出したいのです。

1234567654322344555566787654321

2峰の大体の位置は決まっていて、
例えばど真ん中から左側のMax関数と
右側のMax関数で2ピークトップの数値は得られるとします。
それらのセル位置の間でMin関数で得られると思いますが、
Min関数にセル位置を指定する方法が分からないのです。

ご教授の程よろしくお願いいたします。

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

 その数値はシートのどこにどの様に入力されているのでしょうか？
（´・ω・`） 2021/01/19(火) 21:30

 Sheet1

     |[A]
 [1] |  1
 [2] |  2
 [3] |  3
 [4] |  4
 [5] |  5
 [6] |  6
 [7] |  7
 [8] |  6
 [9] |  5
 [10]|  4
 [11]|  3
 [12]|  2
 [13]|  2
 [14]|  3
 [15]|  4
 [16]|  4
 [17]|  5
 [18]|  5
 [19]|  5
 [20]|  5
 [21]|  6
 [22]|  6
 [23]|  7
 [24]|  8
 [25]|  7
 [26]|  6
 [27]|  5
 [28]|  4
 [29]|  3
 [30]|  2
 [31]|  1
が対象でＢ１に最小値を書き込みます
もっとスマートな方法が有るとは思いますが　＾＾；
単純に考え付いたままに。。。です。。。(￣▽￣)
外していましたら、お許しを。m(__)m
Option Explicit
Sub OneInstanceMain()
    Dim i As Long
    Dim x As Long
    Dim ansa As Long
    Dim ansb As Long
    Dim tmpStr As String
    Dim maxa As Long
    Dim maxb As Long
    Dim c As Long
    Dim r As Range
    Dim vu() As Variant
    Dim vd() As Variant
    Dim t As Date
    Dim var
    With Worksheets("Sheet1")
        .Cells(1, 2) = ""
        c = Int(.Cells(.Rows.Count, 1).End(xlUp).Row / 2)
        Set r = .Cells(1).CurrentRegion
        vu = Intersect(r, .Range(.Rows(1), .Rows(c))).Value
        vd = Intersect(r, .Range(.Rows(c + 1), .Rows(r.Rows.Count))).Value
        maxa = Application.Max(vu)
        maxb = Application.Max(vd)
        ansa = Application.Match(maxa, vu, 0)
        ansb = Application.Match(maxb, vd, 0) + c
        x = Application.Min(Intersect(r, .Range(.Rows(ansa), .Rows(ansb))))
        If Not IsError(x) Then
            For Each var In Intersect(r, .Range(.Rows(ansa), .Rows(ansb)))
                If x = var.Value Then
                    tmpStr = tmpStr & Split(var.Address, "$")(2) & ","
                End If
            Next
            MsgBox tmpStr & "行目" & Chr(13) & .Cells(CLng(Split(tmpStr, ",")(0)), 1)
            .Cells(1, 2) = x
        End If
    End With
    Erase vu, vd
    Set r = Nothing
End Sub
（隠居じーさん） 2021/01/19(火) 21:36

 こんばんは！

 これはトピ主さんにしかわからない暗黙のルールによって違ってくるような気がします。
ご質問の趣旨からすると
左から登って行った時のピークが出発地点で
右から登って行った時のピークが終着地点ですね
その出発地点と終着地点の間の最小値ということですね？
力技で書いてみました。。。(^^;

 Option Explicit
Sub てすと()
Dim MyA As Variant
Dim i As Long
Dim MyS As Long
Dim MyE As Long
Dim MyMin As Double
MyA = Range("A1").Value
For i = 1 To Len(MyA) - 1
  If Mid(MyA, i, 1) < Mid(MyA, i + 1, 1) Then MyS = i + 1
  If Mid(MyA, i, 1) > Mid(MyA, i + 1, 1) Then Exit For
Next
For i = Len(MyA) To 2 Step -1
  If Mid(MyA, i, 1) < Mid(MyA, i - 1, 1) Then MyE = i - 1
  If Mid(MyA, i, 1) > Mid(MyA, i - 1, 1) Then Exit For
Next
For i = MyS To MyE
  If Mid(MyA, i, 1) > Mid(MyA, i + 1, 1) Then MyMin = Mid(MyA, i + 1, 1)
  If Mid(MyA, i, 1) < Mid(MyA, i + 1, 1) Then Exit For
Next
MsgBox "最低値=　" & MyMin
End Sub
（SoulMan） 2021/01/19(火) 21:47

 では、A列に縦にならんでるとして、質問者さんの考えた方法に則って 
    Sub sample()
     Dim nRow As Long, maxPos1 As Long, maxPos2 As Long
     Dim minValue

     With Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
        nRow = .Rows.Count
        With .Resize(nRow \ 2)
           maxPos1 = WorksheetFunction.Match(WorksheetFunction.Max(.Cells), .Cells, 0)
        End With
        With .Resize(nRow - nRow \ 2).Offset(nRow \ 2)
           maxPos2 = WorksheetFunction.Match(WorksheetFunction.Max(.Cells), .Cells, 0)
        End With
        minValue = WorksheetFunction.Min(.Range(.Cells(maxPos1, 1), .Cells(nRow \ 2 + maxPos2)))
        Debug.Print minValue
        Range("B1").Formula = "=MIN(" & .Range(.Cells(maxPos1, 1), .Cells(nRow \ 2 + maxPos2)).Address & ")"
     End With
    End Sub
（´・ω・`） 2021/01/19(火) 22:11

'A列に数字列挙の場合
Sub main()

    Dim r As Range, c As Range
    For Each c In Range("A:A").SpecialCells(2)
        If c.Offset(1).Value < c.Value Then
            If r Is Nothing Then
                Set r = c.Offset(1)
            Else
                Set r = Union(c.Offset(1), r)
            End If
        End If
    Next c
    MsgBox WorksheetFunction.Min(r.Areas(2))
End Sub
（mm） 2021/01/20(水) 09:33

（隠居じーさん）様、（SoulMan） 2様、（´・ω・`）様、（mm）様

お礼が遅くなりすいません、皆さまのスクリプトを全く理解できませんが、質問の数値をA列に入れたものは正解のようです。

また、85列までの小数点入りの実測値を実施してみたところ、（´・ω・`）様、（mm）様のスクリプトで正解が出ました。

できれば（mm）様のスクリプトがシンプルなので、メッセージでなくセルに入力の形式で出せるとうれしいのですが、それすらも自らできないレベルで恐縮ですが、よろしくお願いいたします。

（GGr） 2021/01/21(木) 19:45

 ＞85列までの小数点入りの実測値を実施してみたところ

 どんなデータだったんですか？

 >(mm） 様のスクリプトがシンプルなので

 mmさんのここですが、Areasの2に含まれている保証ってあるんですか？
 　　　　　↓
 ＞MsgBox WorksheetFunction.Min(r.Areas(2))

（半平太） 2021/01/21(木) 20:15

ピークが２つしかないということが保障されているなら、
下記でもOKかな。

 Sub main()
    Dim c As Range, isDown As Boolean
    For Each c In Range("A1").CurrentRegion
        If isDown And c.Offset(1).Value > c.Value Then
            Range("B1").Value = c.Value
            Exit For
        ElseIf c.Offset(1).Value < c.Value Then
            isDown = True
        End If
    Next c

 End Sub

（hatena） 2021/01/21(木) 21:38

すみません。上記は間違いです。スルーしてください。
（hatena） 2021/01/21(木) 21:54

続けて実行すると、CurrentRegionが2列になっちゃって失敗するので、B列初期化を追加。

 Sub main()
    Dim c As Range, isDown As Boolean
    Range("B:B").ClearContents
    For Each c In Range("A1").CurrentRegion
        If isDown And c.Offset(1).Value > c.Value Then
            Range("B1").Value = c.Value
            Exit For
        ElseIf c.Offset(1).Value < c.Value Then
            isDown = True
        End If
    Next c
 End Sub

（hatena） 2021/01/21(木) 22:05

 面白そうなのでトライ
 XLOOKUP使えると、VBA必要なさそうですよね。

    Sub test2()
        Dim e As Long
        Dim s As Long
        Dim i As Long
        e = [match(true,a1:index(a:a,count(a:a))-a2:index(a:a,count(a:a))>0,0)+1]
        For i = [count(a:a)] To e Step -1
            If Cells(i, "A").Value > Cells(i - 1, "A").Value Then
                s = i - 1
                Exit For
            End If
        Next i
        Range("B1").Value = WorksheetFunction.Min(Range(Cells(s, "A"), Cells(e, "A")))
    End Sub
（稲葉） 2021/01/22(金) 15:19

"-40,166" "-30,918" "-20,950" "-10,290" 724 "11,574" "21,767" "31,035" "39,858" "52,099" "64,257" "77,441" "93,015" "112,585" "137,851" "170,219" "210,125" "256,171" "304,419" "348,362" "379,994" "391,978" "380,207" "345,575" "293,992" "234,508" "176,428" "126,740" "88,879" "62,952" "46,927" "38,209" "35,337" "34,033" "33,487" "33,250" "33,110" "33,002" "32,938" "32,962" "33,109" "33,402" "33,855" "34,502" "35,422" "36,748" "38,672" "42,909" "48,807" "56,969" "68,327" "84,243" "106,385" "136,255" "174,334" "219,071" "266,147" "308,582" "338,019" "347,061" "331,875" "293,878" "239,575" "178,462" "119,972" "70,870" "35,760" "20,004" "10,374" "5,005" "2,262" 960 349 9 -257 -507 -719 -860 -919 -925 -926 -964 "-1,055" "-1,191" "-1,349"

確認頻度が少なく申し訳ありません、上記が実測値です。

上記が1行目に並んでいた場合に、同様にA2へ2ピーク間の最低値を書き出すとしたら、どのようにスクリプトを修正すればよいでしょうか。

お手数ですが、ご教示いただき勉強させてください。
よろしくお願いいたします。
（GGr） 2021/01/23(土) 16:08

 ちょっとは自分で理解しようとしたり、修正する努力を見せてほしいものですが
    Sub sample()
     Dim nRow As Long, maxPos1 As Long, maxPos2 As Long
     Dim minValue
     With Range(Cells(1, 1), Cells(1, Columns.Count).End(xlToLeft))
        nCol = .Columns.Count
        With .Resize(, nCol \ 2)
           maxPos1 = WorksheetFunction.Match(WorksheetFunction.Max(.Cells), .Cells, 0)
        End With
        With .Resize(, nCol - nCol \ 2).Offset(, nCol \ 2)
           maxPos2 = WorksheetFunction.Match(WorksheetFunction.Max(.Cells), .Cells, 0)
        End With
        minValue = WorksheetFunction.Min(.Range(.Cells(1, maxPos1), .Cells(1, nCol \ 2 + maxPos2)))
        Debug.Print minValue
        Range("A2").Formula = "=MIN(" & .Range(.Cells(1, maxPos1), .Cells(1, nCol \ 2 + maxPos2)).Address & ")"
     End With
    End Sub
（´・ω・`） 2021/01/23(土) 16:22

 本当にピークは、2つしかないんですね。。

 なら、mmさんのロジックでOKでした。失礼しました。m(__)m

（半平太） 2021/01/23(土) 17:02

ちょっと修正するだけですけどね。

 Sub main2()
    Dim c As Range, isDown As Boolean
    Range("2:2").ClearContents
    For Each c In Range("A1").CurrentRegion
        If isDown And c.Offset(, 1).Value > c.Value Then
           Range("A2").Value = c.Value
            Exit For
        ElseIf c.Offset(, 1).Value < c.Value Then
            isDown = True
        End If
    Next c
 End Sub
（hatena） 2021/01/23(土) 17:24

皆様ありがとうございました。
私のレベルでは魔法のように感じます。
わからないコマンドを一つづつ検索・勉強して
応用が利くようにいたします。

どうもありがとうございました。

GGr
（GGr） 2021/01/23(土) 19:31

コメント返信：

[ 一覧(最新更新順) ]

[[20210119192611]] 『VBAで2峰のピークトップ間の最低値を抜き出したい』（GGr） ページの最後に飛ぶ

[[20210119192611]]　『VBAで2峰のピークトップ間の最低値を抜き出したい』（GGr）　ページの最後に飛ぶ