[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『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 が対象でB1に最小値を書き込みます もっとスマートな方法が有るとは思いますが ^^; 単純に考え付いたままに。。。です。。。( ̄▽ ̄) 外していましたら、お許しを。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
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
お礼が遅くなりすいません、皆さまのスクリプトを全く理解できませんが、質問の数値を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
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
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
確認頻度が少なく申し訳ありません、上記が実測値です。
上記が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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.