ExcelVBAのデータの連続する個数の検索

質問

A～Fの各列ごとに、121以上の数字が連続する個数を出力し、出力したデータの最大値を求めたいのですが、どうやって式を組んだらいいか、わかりません。
アドバイスいただけましたら幸いです。

A / B / C / D / E / F
118.19 / 118.11 / 118.22 / 118.20 / 118.20 / 118.74
120.93 / 120.86 / 120.96 / 120.92 / 120.92 / 121.44
123.45 / 123.35 / 123.45 / 123.43 / 123.43 / 123.88
120.97 / 121.04 / 120.94 / 121.00 / 120.97 / 120.93
118.57 / 119.48 / 118.69 / 121.52 / 118.48 / 119.69
123.48 / 123.35 / 123.44 / 123.43 / 123.41 / 123.61
123.59 / 120.47 / 123.58 / 123.57 / 123.57 / 123.74

連続する個数
1コ / 2コ / 1コ / 5コ / 1コ / 2コ
2コ / 1コ / 2コ / - / 2コ / 2コ

最大値
2コ /2コ /2コ /5コ /2コ /2コ

回答No.3

cj_mover · ベストアンサー

こんにちは。お邪魔します。

元の表の下に、
　１行空けて
　"最大値"タイトル
　"最大値"各列の値
　"連続する個数"タイトル
　"連続する個数"各列各連続区間の数（行数不明）
といった順にに出力するように書きました。
（連続する区間の数がUnkwonですから仕方ないかと）
1コ、とか、2コ、とか、単位を表示したい場合は、
[セルの書式設定][表示設定]で工夫した方がいいと思います。

処理の流れだけ、以下。
　・テーブル全体を捉える
　・行数を取得する
　・テーブルを各列毎にループ
　・各列を 下に一行拡張させた範囲で捉えなおして各単セル毎にループ
　　　各単セルの値が閾値以上である場合、カウンタを１増加
　　　各単セルの値が閾値未満で 且 カウンタが0より大きい場合、
　　　　カウンタが各列の最大値より大きい場合、最大値を更新
　　　　各連続区間の"連続する個数"について
　　　　出力する行位置を増加させながら、出力（→初期化）
　　各単セル毎のループが終わったら各列の最大値を出力（→初期化）
こんな感じです。

' ' =========================ここから===========================

Sub Re_7681627c()

　　Const THRESH As Double = 121# ' 閾値を指定。

　　Dim rCol As Range ' ループ内で【各列】をポイントする変数
　　Dim rH As Range ' ループ内で【各単セル】をポイントする変数
　　Dim nRows As Long ' テーブルの行数（レコード数）
　　Dim nPrtRow As Long ' "連続する個数"を出力する行位置
　　Dim nCnt As Long ' "連続する個数"カウンタ
　　Dim nLongest As Long ' 各列の"最大値"

　　With Cells(2, 2).CurrentRegion ' 運用に合わせて適宜指定してください
　　　　nRows = .Rows.Count
　　　　For Each rCol In .Columns
　　　　　　nPrtRow = nRows + 4
　　　　　　For Each rH In rCol.Resize(nRows + 1).Cells
　　　　　　　　If rH.Value >= THRESH Then
　　　　　　　　　　nCnt = nCnt + 1
　　　　　　　　ElseIf nCnt > 0 Then
　　　　　　　　　　If nCnt > nLongest Then nLongest = nCnt
　　　　　　　　　　nPrtRow = nPrtRow + 1
　　　　　　　　　　rCol.Cells(nPrtRow).Value = nCnt
　　　　　　　　　　nCnt = 0
　　　　　　　　End If
　　　　　　Next rH
　　　　　　rCol.Cells(nRows + 3).Value = nLongest
　　　　　　nLongest = 0
　　　　Next rCol
　　　　.Cells(nRows + 2, 1).Value = "最大値"
　　　　.Cells(nRows + 4, 1).Value = "連続する個数"
　　End With

End Sub

' ' =========================ここまで===========================

お礼

数式がそのまま使えて、しかも説明付きでとてもわかりやすかったです。
とても勉強になりました。
ありがとうございました。

回答No.4

Siegrune

VBAを使わずとも、データがあるシートをSheet1とすると、
Sheet2に例えば以下のような式を入れて
（Sheet1の同じセルが121以上かを判定して、以上なら、Sheet2の１つ上のセルの値に+1する。
違ったら0を入れる。一番上の列だけ１つ上のセルがないので、+1でなく1を入れる）
例）sheet2のA1セル
=if(row()=1,if(sheet1!A1 >= 121,1,0),if(sheet1!A1 >= 121,1 + offset(A$1,row()-1,0,1,1))

これをA1セルに入れてコピー＆A1セルからF???(最大行)セルまで指定して貼り付けし、

sheet3に
A1セルに
=max(sheet2!A:A)
B1セルに
=max(sheet2!B:B)
・・・
とかいう風にしたら最大値は式だけで求まるはずですが。

Sheet2に出てくる結果
A/B/C/D/E/F
0/0/0/0/0/0
0/0/0/0/0/1
1/1/1/1/1/2
0/2/0/2/0/0
0/0/0/3/0/0
1/1/1/4/1/1
2/0/2/5/2/2

Sheet3には、MAXを求めるので
2/2/2/5/2/2
とでてくる。

（未検証。多少数式を間違っているかもしれませんがご勘弁。）

お礼

こういうやり方もあるんですね。参考になりました。ありがとうございました。

回答No.2

米沢 栄蔵（@YON56）

最大値:Aを求めるには、次式が最速です。
A = Application.WorksheetFunction.Max(Range("A1:A100"))
「最大値を求める範囲と、要求される最大値の個数をどういう方法で取得するか。」
ということが明確になっていれば簡単だと思います。

Application.WorksheetFunctionが使えない場合は、
For W=1 To X
For Y=1 To Z
If Cells(W,Y).Value>A Then
A= Cells(W,Y).Value
End If
Next Y
Next W
「最大値を求める範囲と、要求される最大値の個数を取得したデータがXとZです。

最大値の同値個数は、
B= Application.WorksheetFunction.Countif(Range("A1:A100"),A)

お礼

細かな説明付きで参考になりました。
ありがとうございました。

回答No.1

mu2011

一案です。
10行目から連続個数、１５行目にMAX数を表示しています。
ご例示のデータサイズによる暫定版ですので後は調整して下さい。

Sub sample()
Dim i As Integer, j As Integer, n As Integer
Dim wk()
n = -1
flg = False
For j = 1 To 6
For i = 1 To 7
If Cells(i, j) >= 121 Then
If flg Then
wk(n) = wk(n) + 1
Else
flg = True
n = n + 1
ReDim Preserve wk(n)
wk(n) = wk(n) + 1
End If
Else
flg = False
End If
Next
For i = 0 To UBound(wk)
Cells(i + 10, j) = wk(i)
Next
Cells(15, j) = Application.Max(wk)
Erase wk: n = -1
flg = False
Next
End Sub

お礼

プロシージャの作成方法も含めて、数値の求め方はとても参考になりました。
ありがとうございました。