データのカウント方法を教えてください

質問

C列からＫ列の10行目以降に数値（1～250まで）が入力していいます（全ての行に入力されているわけではなくところどころ空欄があります。
各列について3行連続、4行連続　5行連続　5行以上連続でデータが入力されているセルの数
（Ｃ12空欄、Ｃ13～Ｃ15入力あり、Ｃ16空欄なら3行連続が１個という感じ）
を数えて結果をM6～U9に表示（C行の3行連続の数をＭ6、4行連続の数をM7・・
D列の3行以上連続をN6,4行以上連続をN7・・・）したいのですがどうしたらいいでしょうか。workseets_changeイベントでの方法をお願いします

回答No.4

papayuka · ベストアンサー

書かれたコードがあるなら最初から提示して下さい。
ご自身でここまで書けるなら修正だって出来そうなもんですが、、、
別の人が書いたのかな？

不具合の解説は Wendy02さんがされてますのでしませんが、どうしても Change でやるなら無駄なループは出来るだけ無くした方がレスポンスが良いと思います。
Change された Range として 引数 Target がある訳ですから、それ以外のセルを全て見直す必要は無いように思います。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ChkCells, r As Range, AR As Range, ARCount(6) As Long, i As Integer

For Each r In Target
　　If r.Column >= 3 And r.Column <= 11 Then
　　　Erase ARCount
　　　On Error GoTo ER:
　　　Set ChkCells = Range(Cells(10, r.Column), Cells(65536, r.Column)). _
　　　　　　　　　　　　　SpecialCells(xlCellTypeConstants, xlNumbers)
　　　If Not ChkCells Is Nothing Then
　　　　 For Each AR In ChkCells.Areas
　　　　　　Select Case AR.Count
　　　　　　　Case 3 To 5: ARCount(AR.Count) = ARCount(AR.Count) + 1
　　　　　　　Case Is > 5: ARCount(6) = ARCount(6) + 1
　　　　　　End Select
　　　　 Next
　　　End If
　　　Application.EnableEvents = False
　　　　For i = 6 To 9
　　　　　　Cells(i, r.Column + 10) = ARCount(i - 3)
　　　　Next i
　　　Application.EnableEvents = True
　　End If
Next r
　　Exit Sub
ER:
　　Set ChkCells = Nothing
　　Resume Next
End Sub

回答No.3

Wendy02

#1のコメントのレス

＞Worksheet_Changeで実行できるようにできないでしょうか？
申し訳ありませんが、それは出来かねますね。

今は、動かしてはみないけれども、コードを読むと、所々ヘンな部分もあるけれど、やはり、根本的に、今のままでWorksheet_Changeしたら、計数できない、としか読めません。もう少し、何か複合的な条件がなければできませんね。

コードの中でも、条件は、これ一行ですから。
If (Target.Column < 3 Or Target.Column > 7) Then Exit Sub
それでは、足りませんし、コマンド・ボタンのほうが有効です。

コードの内容的には、Case の条件が重なっていたり、中途半端な変数宣言もあるけれど、テクニックとかは、かなり凝った作りになっています。

私としては、もし、ご自身でそこまで作ったらなら、何とか、ご自身で満足するものを作っていただきたいなって思いますし、そうでないのでしたら、なるべく、ロング・スパンでお付き合いしてくれる、VBA専用掲示板のほうがよいかもしれませんね。

＞これをこのまま使うと各列の1～9行目の値もカウントしてしまいます。

ループで、i　には、列の数字を入れます。
　Range(Cells(10,i), Cells(65536,i).End(xlUp)).SpecialCells～

＞さらに
＞原因ががわからないのですが、各列において3回以上連続が1回以上出ないと正
＞常に動作しません。Ｃ列に3回連続が一回だけあり、ほかの列にまったくデー
＞タがない場合、

たぶん、それは変数の残骸の消し忘れだと思います。
「On Error GoTo 0」はしても、変数は、以前のものが残ります。
ループで使う時には気をつけるというのが鉄則です。

＞I5にだけ1と表示去ればいいのですがＩ5からＩ9全てに1と表示されてしまいます。
たぶん、配列の出力のの縦と横が違っているのでしょうね。

それと、よけいなことですが、
私は、
　Dim ARCount(2 To 15) As Long
１次元の配列の添え字の初期値を、２にはしないですね。（^^;
ループでは、こちらが簡単なのは分かるけれども。
勝手な言い分で、お気を悪くしませんように。

回答No.2

papayuka

#1さんのおっしゃるように、workseets_changeイベントでやるような処理では無いと私も思います。
あんまりスマートじゃないけど。

Sub Test()
Dim myCol As Integer, LRow As Long, i As Long, cnt As Long
Range("M6:U9").ClearContents
　For myCol = 3 To 11
　　LRow = Cells(65536, myCol).End(xlUp).Row
　　i = 10
　　Do While i <= LRow
　　　cnt = 0
　　　　　Do
　　　　　　　cnt = cnt + 1
　　　　　　　i = i + 1
　　　　　Loop Until Cells(i, myCol).Value = ""
　　　Select Case cnt
　　　Case 3:
　　　　Cells(6, myCol + 10).Value = Cells(6, myCol + 10).Value + 1
　　　Case 4:
　　　　Cells(7, myCol + 10).Value = Cells(7, myCol + 10).Value + 1
　　　Case 5:
　　　　Cells(8, myCol + 10).Value = Cells(8, myCol + 10).Value + 1
　　　Case Is > 5:
　　　　Cells(9, myCol + 10).Value = Cells(9, myCol + 10).Value + 1
　　　End Select
　　　i = i + 1
　　Loop
　Next myCol
End Sub

補足

すみません。Wendy02さんの解答に補足している途中で間違って書き込みボタンを押してしまいました。
続きをこちらに書かせていただきます。
下記のプログラムはＣからＧ列における3～5回以上の数をカウントし、結果をＩ5からＭ5に表示するプログラムです。これをこのまま使うと各列の1～9行目の値もカウントしてしまいます。さらに原因ががわからないのですが、各列において3回以上連続が1回以上出ないと正常に動作しません。Ｃ列に3回連続が一回だけあり、ほかの列にまったくデータがない場合、
I5にだけ1と表示去ればいいのですがＩ5からＩ9全てに1と表示されてしまいます。
下記のプログラムを変化させてWorksheet_Changeで実行できるようにできないでしょうか？

回答No.1

Wendy02

＞workseets_changeイベントでの方法をお願いします

なぜ、Worksheets_Changeイベントなのですか？

シートに何かを入力した時点で、計数が始ってしまうので、イベントに対して、累計していくのだから集計にならないと思います。コマンド・ボタンとかでないと、確実に数えられないと思います。

もしくは、どこか一定のキーになるものがあって、イベントが働くとか？
連続したセルの数を数えるマクロは、そんなに難しいものじゃありませんけれどね。

補足

ご回答ありがとうございます。以前下記のプログラムで同じような処理をやっていました。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ChkCells As Range
Dim AR As Range
Dim ARCount(2 To 15) As Long
Dim i As Integer
If (Target.Column < 3 Or Target.Column > 7) Then Exit Sub
j = 9
For i = 3 To 7

Erase ARCount
On Error Resume Next

Set ChkCells = Columns(i).SpecialCells(xlCellTypeConstants, xlNumbers)
On Error GoTo 0
If Not ChkCells Is Nothing Then

For Each AR In ChkCells.Areas
Select Case AR.Count
Case 3 To 6: ARCount(AR.Count) = ARCount(AR.Count) + 1
Case Is >= 6: ARCount(7) = ARCount(7) + 1
End Select
Next
End If
For ii = 3 To 7
Cells(ii + 2, j).Value = ARCount(ii)
Next
j = j + 1
Next
End Sub