【EXCEL】連続データの個数を抽出する方法を御教授ください

質問

申し訳ありませんが、どなたかお助けください。

日付が横軸、名前が縦軸にあります。
該当する場合には1が立ち、該当がなければデータは表示されません。
１か月の中で、連続するデータの最大個数を求めたいのですが、
よくわかりません。
なにとぞよろしくお願いします。

　　Ａ　　Ｂ　　　Ｃ　　Ｄ　　　Ｅ　　Ｆ
１　　　　4/1　　4/2　　4/3　　4/4　　4/5
２　鈴木　1　　　　　　　1　　　1
３　田中　　　　　1　　　1　　　1　　　1
４　佐藤　　　　　1　　　　　　　1

上のデータのみで月末を迎えたら、
鈴木=(最大)2
田中=(最大)4
佐藤=(最大)1
※できれば２以上の連続する個数を求めたいので、
　佐藤はデータなしとしたいです。

Count
Index
Max
あたりを使用するように思えるのですが、
情けないかな、うまく関数を使いこなせないのです。
申し訳ありませんが、
お力をお貸しください。

回答No.1

chiezo2005 · ベストアンサー

http://oshiete1.goo.ne.jp/qa148656.html
でできそうです。

お礼

chiezo2005 様
早速のレスありがとうございます。
おかげさまで、できました！！
大変わかりやすかったです。
本当に感謝です。

回答No.7

imogasi

＞Count　Index　Max　あたりを使用するように思えるのですが、・・
多分見当ハズレです。関数は１つのセルの値を調べたり・値で条件を考えセルの数を数えたりは出来ますが、
位置関係（連なり、配置・セルの値の存在情況パターン）まで条件になると、力を発揮できません。３セルが順にa、b、ｃのあるシート上のあり場所も関数で探すのは難しいと思う。
ーー
＃２のご回答の方法も昨晩から考えましたが、例えば４連の時、１２３４と１２３もセルに出てしまうので、４だけカウントするのが難しく思いました。
４だけシートに出る関数組み合わせが可能かを考えて見ます。
そうすればCOUNTIFで連の数の統計がたやすく取れると思う。
＝＝＝＝＝＝
ですからVBAでやらざるを得ないと思います。
例データA1:H8　A-H列
1 4月1日 4月2日 4月3日 4月4日 4月5日 4月6日 4月7日
2 鈴木 1 1 1 1
3 田中 1 1 1 1
4 佐藤 1 1 1 1
5 川田 1 1 1 1 1
6 島田 1 1 1 1
7 三島 1 1 1
8 木村 1 1 1 1 1
結果
K-N列　K1:N8　第1行は連続日数（見出しとしてのもの。文字列可）
1 2 3 4
1 1
1
2
1 1
2 1
3
1 1
コード
標準モジュールに
Sub test01()
d = Range("B65536").End(xlUp).Row
MsgBox d
For i = 2 To d '第2行から最下行まで行単位の処理を繰り返し
r = 0
For j = 3 To 8 'C列からH列まで１かどうかチェック
If Cells(i, j) = 1 Then
'--１の場合 rはその列まででの連なりの数を示す
r = r + 1
MsgBox i & "行・連　" & r
Else
'--空白の場合　連が途切れ、連の個数分類をK列以右対応列に記録
'ただしこの列空白でも、前の列のセルが空白なら処理スキップ
If Cells(i, j - 1) <> "" Then
Cells(i, 10 + r) = Cells(i, 10 + r) + 1
r = 0
End If
End If
Next j
If r <> 0 Then
Cells(i, 10 + r) = Cells(i, 10 + r) + 1
r = 0
End If
Next
End Sub
ただこの処理ロジックは注意点があって、意外に経験を要するようにも思うが。
ーー
実際の場合には
４月７日までになっているが、日数＝列数を増やす。
＝＝＞For j = 3 To 8の８を増やす。
それに伴い結果を出すセルをより右列にずらす必要あり。
Cells(i, 10 + r) = Cells(i, 10 + r) + 1の１０を増やすか、
いっそ別シートに出すようにコードを改める（コード略）
対象者の増加は、コードをいじくる必要なし。

お礼

imogasi　様

親身になって考えてくださり、
本当にありがとうございました。
ＶＢＡもう少し勉強します。

回答No.6

merlionXX

もし表の配置がお書きになったようにA1から始まり、１行目が日付、A列が氏名で、条件に該当するセルには数値が入力されているなら、
以下の手順をおためしください。
もし数値が入力されているのではなく、数式の結果で表示されているのなら
For Each myArs In myRng.Item(i).Offset(0, 1).Resize(, x - 1).SpecialCells(xlCellTypeConstants, 1).Areas 'ここを書き換え
の部分を
For Each myArs In myRng.Item(i).Offset(0, 1).Resize(, x - 1).SpecialCells(xlCellTypeFormulas, 1).Areas
に書き換えてください。

1.AltキーとF11キー同時に押し（以下Alt+F11キーと記述）て Visual Basic Editor を呼び出します。

2.Visual Basic Editor のメニューから「挿入」、「標準モジュール」で出てきたコードウィンド（右側の白い広い部分）に以下のコード（Sub～End Sub）をコピペします。

'********これより下**********

Sub test01()
Dim ws As Worksheet, ns As Worksheet
Dim myRng As Range, myArs As Range
Dim x As Long, y As Long, i As Long, n As Long, z As Long
Dim myCnt()
Set ws = ActiveSheet
Set ns = Sheets.Add(After:=ws)
Set myRng = ws.Range("A1").CurrentRegion.Rows
x = ws.Range("A1").CurrentRegion.Columns.Count
y = myRng.Rows.Count
For i = 2 To y
ReDim Preserve myCnt(i - 2)
For Each myArs In myRng.Item(i).Offset(0, 1).Resize(, x - 1).SpecialCells(xlCellTypeConstants, 1).Areas 'ここを書き換え
z = IIf(myArs.Cells.Count > myCnt(i - 2), myArs.Cells.Count, myCnt(i - 2))
Next myArs
myCnt(i - 2) = IIf(z > 1, z, "なし")
Next i
ns.Range("A1").Resize(UBound(myCnt) + 1).Value = ws.Range("A2").Resize(UBound(myCnt) + 1).Value
ns.Range("B1").Resize(UBound(myCnt) + 1).Value = Application.Transpose(myCnt)
End Sub

'********これより上**********

3.Alt+F11キーでワークシートへもどります.

4.Alt+F8キーで出てきたマクロ名（test01）を選択して実行します。
これで、新しいシートを挿入し、そこに表示されます。

お礼

merlionXX　様
お忙しいところ、ありがとうございました。
ＶＢＡがわかるよう、今年はチャレンジします。

回答No.5

okdeath

こんにちわ。
方法としてはtom04さんの方法でよいとおもいます。
（私はＶＢＡわかんないので・・）
でも、計算式は別のシートにするか、下、又は横に張ったほうがあとで元データ又は計算式の修正をするときに楽です。

　　Ａ　　Ｂ　　　Ｃ　　Ｄ　　　Ｅ　　Ｆ
１　　　　4/1　　4/2　　4/3　　4/4　　4/5
２　鈴木　1　　　　　　　1　　　1
３　田中　　　　　1　　　1　　　1　　　1
４　佐藤　　　　　1　　　　　　　1
５
６　計算式用のスペース
７　鈴木　1　　　　0　　　1　　　2　　　0
８　田中　0　　　　1　　　2　　　3　　　4
９　佐藤　0　　　　1　　　0　　　1　　　0
１０

隙間に計算式いれると後々めんどうだとおもったもので。
そんなことわかってるて？失礼しました＞＜

お礼

お忙しいところ、一緒になって考えてくださり、
本当にありがとうございます。
皆様のアドバイスにより、だんだんとエクセルが面白くなってきています。

回答No.4

tom04

No.2です！
たびたびごめんなさい。

先ほどの回答で佐藤さんとしましたが、鈴木さんの間違いでした。

そして数式を
=IF(MAX(B3:AE3)<=1,"データなし",MAX(B3:AE3))
として田中さん・佐藤さんも同じようにやっていただければいいのではないかと思います。

どうも失礼しました。m(__)m

回答No.3

mitarashi

難しい関数より、SpecialCellsを使って、ユーザー定義関数で簡単に、と思ったのですが、SpecialCellsはユーザー定義関数中では所期の動作をしない様です。仕方なくマクロとしましたが、折角作ったので載せておきます。マクロが嫌ならスルーしてください。なお、A列の途中に空白行があると、そこで処理を打ち切ってしまいます。当方、XL2000です。
Sub test()
Dim myCell As Range
Dim retVal As Long

Set myCell = Range("a2")
Do While myCell.Value <> ""
retVal = maxBlock(myCell.Offset(0, 1).Resize(, 31))
If retVal > 1 Then myCell.Offset(0, 32).Value = retVal
Set myCell = myCell.Offset(1, 0)
Loop
End Sub

Private Function maxBlock(target As Range) As Long
Dim myArea As Range
Dim targetrange As Range

Set targetrange = target.SpecialCells(xlCellTypeConstants, xlNumbers)
For Each myArea In targetrange.Areas
If myArea.Cells.Count > maxBlock Then maxBlock = myArea.Cells.Count
Next myArea
End Function

お礼

貴重なお時間をさいて検討してくださり
本当にありがとうございました。

回答No.2

tom04

こんばんは！
スマートな方法ではないのですが・・・

↓の画像のように水色部分にすべて作業列を挿入します。

B3セル=A3*B2+B2
B5セル=A5*B4+B4
B7セル=A7*B6+B6
としてオートフィルで右へコピーしていきます。
連続している場合のみ2以上の数値が表示されると思いますので

仮に佐藤さんの場合、連続最大値のセルに
=MAX(B3:AE3)　←（1日～30日までのデータ）
とすれば希望の数値になるのではないでしょうか？
あくまで「1」という数値が入る前提での回答です。

色々関数を駆使すればもっとすっきりした方法があるかもしれませんが、
素人っぽい回答で申し訳ございません。
今はこの程度しか思い浮かびませんでした。
以上、参考になれば幸いですが
的外れ・他に良い方法があれば読み流してください。m(__)m