エクセルで連勤チェックをしたいです。

画像みたいな感じで、５連勤、６連勤、7連勤・・・と、それぞれ連勤があるかないかをチェックをしたいのですが、５連勤以上しか見ることができず、６連勤があっても５連勤もありになってしまいます。関数でこうした処理は不可能でしょうか？

マクロもChatGPTと一緒に頑張ってみたんですが、こちらの伝え方が悪いのかどうがんばっても重複処理をしてしまいます。

それぞれの連勤回数を出力するようにできないでしょうか？

Sub CountConsecutive()
Dim dataRange As Range
Dim cell As Range
Dim consecutiveCount As Integer
Dim output5Consecutive As Range
Dim output6Consecutive As Range
Dim output7Consecutive As Range
Dim output8Consecutive As Range
Dim output9Consecutive As Range
Dim output10Consecutive As Range
Dim set5ConsecutiveCount As Integer
Dim set6ConsecutiveCount As Integer
Dim set7ConsecutiveCount As Integer
Dim set8ConsecutiveCount As Integer
Dim set9ConsecutiveCount As Integer
Dim set10ConsecutiveCount As Integer
Dim isConsecutive As Boolean
Dim ignoreCounts As Collection
Dim ignoreCount As Integer

' データの範囲を指定（F5:AJ5に合わせて変更）
Set dataRange = Range("F5:AJ5")

' 5回連続の結果を出力するセルを指定（AY7に合わせて変更）
Set output5Consecutive = Range("AY7")

' 6回連続の結果を出力するセルを指定（AZ7に合わせて変更）
Set output6Consecutive = Range("AZ7")


' 初期化
consecutiveCount = 0
set5ConsecutiveCount = 0
set6ConsecutiveCount = 0
set7ConsecutiveCount = 0
set8ConsecutiveCount = 0
set9ConsecutiveCount = 0
set10ConsecutiveCount = 0
isConsecutive = False
Set ignoreCounts = New Collection

' データを順に確認
For Each cell In dataRange
If cell.value = "出勤" Then
consecutiveCount = consecutiveCount + 1
isConsecutive = True
Else
If isConsecutive Then
' 10回以上連続の場合は無視
If consecutiveCount >= 10 Then
ignoreCount = 10
Else
' 5回以上連続の場合
If consecutiveCount >= 5 And Not Contains(ignoreCounts, consecutiveCount) Then
set5ConsecutiveCount = set5ConsecutiveCount + 1
ignoreCounts.Add consecutiveCount
End If
' 6回以上連続の場合
If consecutiveCount >= 6 And Not Contains(ignoreCounts, consecutiveCount) Then
set6ConsecutiveCount = set6ConsecutiveCount + 1
ignoreCounts.Add consecutiveCount
End If
Then
set10ConsecutiveCount = set10ConsecutiveCount + 1
ignoreCounts.Add consecutiveCount
End If
End If
isConsecutive = False
consecutiveCount = 0
End If
End If
Next cell

' データ範囲の最後で5回以上連続している場合
If consecutiveCount >= 5 And Not Contains(ignoreCounts, consecutiveCount) Then
set5ConsecutiveCount = set5ConsecutiveCount + 1
ignoreCounts.Add consecutiveCount
End If

' データ範囲の最後で6回以上連続している場合
If consecutiveCount >= 6 And Not Contains(ignoreCounts, consecutiveCount) Then
set6ConsecutiveCount = set6ConsecutiveCount + 1
ignoreCounts.Add consecutiveCount
End If


' 結果を出力
output5Consecutive.value = "5回以上連続：" & set5ConsecutiveCount & "セット"
output6Consecutive.value = "6回以上連続：" & set6ConsecutiveCount & "セット"

End Sub
Function Contains(col As Collection, value As Variant) As Boolean
On Error Resume Next
Contains = (col.Item(value) <> 0)
On Error GoTo 0
End Function

No.7 回答者： Qchan1962 回答日時： 2023/12/25 16:08

連投すみません

Functionで配列を返しています
As Variant型なので初期値はEmptyで　0が返りません
0を出力したい場合はFunctionの戻り型とFunction内の一時受けの変数の型を数値型に変更してください（IntegerまたはLong）

Private Function CountConsecutive_1(rng As Range, Fdkey As String, minimum As Integer) As Integer()
Dim x As Integer, arr() As Integer

No.6 回答者： Qchan1962 回答日時： 2023/12/25 15:42

＃３です

＞10連勤
連勤は例えなのでしょうけれど　黒いですねW　　
出力セルがAY7→5，6，7・・・ならば
5以上の連勤を連勤ごとの回数を全て出す　セルの色とかもいらないのなら
Select Caseは不要ですね

＞自力で頑張ってみます
全部VBAで処理する場合、分かり難い書き方をしてしまいましたので　ちょっと添削（余計分かり難くなってればごめんなさい）

Set dataRng = Range("F5:AJ5")　データ範囲
Set output5 = Range("AY7")　5連勤を出力セル

Range("F5:AJ10")とすると１行ずつ処理　出力は相対位置に出力

少しまとめた方が良いかもですが　ステップ実行やdebug.Print
変数のtargetArea.Selectなどを差し込んで確認すると良いかも

自力でとの事なので余計なお世話ですが　一例の参考程度に

Sub test()
Const minimum As Integer = 5
Const kWord As String = "出勤"
Dim dataRng As Range
Set dataRng = Range("F5:AJ5")
Dim output5 As Range
Set output5 = Range("AY7")
Dim ans As Variant
Dim c As Long, r As Long
c = output5.Column - dataRng(dataRng.Columns.Count).Column
r = output5.Row - dataRng(1).Row
Dim targetArea As Range
Dim i As Long
For i = 1 To dataRng.Rows.Count
Set targetArea = dataRng.Areas(i)
ans = CountConsecutive_1(targetArea, kWord, minimum)
On Error Resume Next
targetArea.Item(targetArea.Count).Offset(r, c).Resize(, UBound(ans) + 1).Value = ans
Next
End Sub

Private Function CountConsecutive_1(rng As Range, Fdkey As String, minimum As Integer) As Variant()
Dim target As Range
Dim firstAddress As String
Dim getRng As Range
Set target = rng.Find(What:=Fdkey, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
After:=rng(rng.Count), _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
MatchByte:=False)
If target Is Nothing Then
'MsgBox "出勤はヒットしませんでした"
Else
firstAddress = target.Address
Set getRng = target
Do
Set getRng = Union(getRng, rng.FindNext(target))
Set target = rng.FindNext(target)
If target Is Nothing Then Exit Do
Loop While target.Address <> firstAddress
End If

Dim i As Integer, n As Integer
Dim x As Integer, arr()

For i = 1 To getRng.Areas.Count
If n < getRng.Areas(i).Count Then n = getRng.Areas(i).Count
Next
If n >= minimum Then
ReDim arr(0 To n - minimum)
Else
'MsgBox minimum & "連勤以上はヒットしませんでした"
Exit Function
End If
For i = 1 To getRng.Areas.Count
x = getRng.Areas(i).Count - minimum
If x >= 0 Then
arr(x) = arr(x) + 1
End If
Next
CountConsecutive_1 = arr

End Function

No.5 回答者： fujillin 回答日時： 2023/12/25 14:30

No2です。

＞1か月の出勤日の中に、5連勤以上の勤務がそれぞれ何回あるかを数えたいというものでした。
えぇと・・・
例えば、連続勤務のブロックが、「3連勤、5連勤、7連勤、6連勤」とあった際に、
5連勤以上は3ブロックなので3を求めたいのか、あるいは、7連勤の内部を見ると初日から見れば7連勤、二日目から見れば6連勤・・なので7連勤内で5以上は3日、全体では6日として6を求めたいのかどちらなんでしょうね？

No2の関数内部で、vにはそれぞれの日から数えた連勤数が得られていますので、前者の数え方であれば5が何個あるか、後者の数え方であれば5以上が何個あるかを数えれば求められます。
COUNTIF関数で求められるかと思いましたが、COUNTIFで配列は使えないようなので、直接ループで数える方法にして追加修正してみました。
併せて、数えたい連勤数も指定できるように引数として追加してあります。
　=countc(セル範囲, 指定文字列, 指定連続数）
で求められます。


以下は、上記のうちの前者のカウント方法での例です。
（セル範囲の行数は1行という前提は同じままです。）

Function countC(ByRef r As Range, ByRef s, ByRef c As Long) As Long
Dim i As Long, j As Long, n As Long
Dim v

v = r.Rows(1).Cells.Value
For i = 1 To UBound(v, 2)
n = 0
For j = i To UBound(v, 2)
If v(1, j) = s Then n = n + 1 Else Exit For
Next j
v(1, i) = n
Next i

countC = 0
For i = 1 To UBound(v, 2)
If v(1, i) = c Then countC = countC + 1
Next i
End Function

※ 後者のカウント方法にしたければ、cで判定しているカウント数を、ｃ以上でカウントすれば求められます。

No.4 回答者： yokomaya 回答日時： 2023/12/25 13:16

No1です。

私は関数を回答した覚えはありませんし
連勤開始セルに色がつくから座標も明白です。
返答の位置を誤っておられませんか？

条件付き書式は試して頂けないのでしょうか？

この回答へのお礼

すみません、一番最初に返事させていただいたのですが、条件付き書式でも試させていただきました。
おっしゃる通りの結果が帰ってきました。
ありがとうございます。

お礼日時：2023/12/25 13:31

No.3 回答者： Qchan1962 回答日時： 2023/12/25 13:11

>画像みたいな感じで、５連勤、６連勤、7連勤・・・と、それぞれ連勤があるかないかをチェックをしたいのですが

範囲に５連勤がいくつ6連勤がいくつ・・・って事かな？
出力１セルみたいですけれど・・・最大連勤数なら＃２様が回答されていますので　以下は読み飛ばしてください

画像が良く見えないのでコードの使用アドレスから想像して
AIのコードを添削するのはしんどそうなので　
勝手な解釈で　新しく書くと

FIDで探してAreaを取得Areaの大きさで連続セルとして条件　カウント
範囲を変えるかもしれないのでPrivate Functionとして　出力をAY7から
右に5連勤・・8連勤回数
Case 5　が　5連勤　ブロックの処理　n5はカウント変数
.ColorIndex = で　セルの色設定（コメント化で実行されないです）

Private Function CountConsecutive_1の戻り値は配列
CountConsecutive_1 = Array(n5, n6, n7, n8)
可変もできますが、とりあえず4つにしています

呼び出しや上記を条件に合わせて変更してください
とりあえず
一例のサンプル
Sub test()
Dim ans As Variant
ans = CountConsecutive_1(Range("F5:AJ5"), "出勤")
Range("AY7").Resize(, UBound(ans) + 1).Value = ans
End Sub

Private Function CountConsecutive_1(rng As Range, fdKey As String) As Variant()
Dim target As Range
Dim firstAddress As String
Dim getRng As Range
Set target = rng.Find(What:=fdKey, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
After:=rng(rng.Count), _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
MatchByte:=False)
If target Is Nothing Then
'MsgBox "出勤はヒットしませんでした"
Else
firstAddress = target.Address
Set getRng = target
Do
Set getRng = Union(getRng, rng.FindNext(target))
Set target = rng.FindNext(target)
If target Is Nothing Then Exit Do
Loop While target.Address <> firstAddress
End If

Dim i As Integer
Dim n5 As Integer, n6 As Integer, n7 As Integer, n8 As Integer
For i = 1 To getRng.Areas.Count
Select Case getRng.Areas(i).Count
Case 5
'getRng.Areas(i).Interior.ColorIndex = 33
n5 = n5 + 1
Case 6
'getRng.Areas(i).Interior.ColorIndex = 6
n6 = n6 + 1
Case 7
'getRng.Areas(i).Interior.ColorIndex = 3
n7 = n7 + 1
Case 8
'getRng.Areas(i).Interior.ColorIndex = 39
n8 = n8 + 1
End Select
Next

CountConsecutive_1 = Array(n5, n6, n7, n8)

End Function

この回答へのお礼

こんなにわかりづらいコードだったのに、的確な回答ありがとうございます。

期待通りの結果が出ました。

10連勤があると、9連勤もカウントされてしまうのですが、ここからはいただいたコードを参考にさせていただいて、自力で頑張ってみます。

本当にありがとうございました。

お礼日時：2023/12/25 13:26

No.2 回答者： fujillin 回答日時： 2023/12/25 12:45

こんにちは

＞関数でこうした処理は不可能でしょうか？
可能とは思いますが、かなり面倒な計算になりそうに思います。
多分、VBAを利用する方が簡単ではないでしょうか。

一方で、ご提示の図は読解できない上に、機能しないコードを見せられても、何をどうしたいのかさっぱりわかりません。

勝手に解釈して、
　「1行の連続範囲内で、指定文字が連続して出現する最大数を数える」
ということと解釈しました。
意味が違っている場合は、以下は無視してください。


以下の、ユーザ定義関数で可能と思います。
（事前に、標準モジュールにコピペしておいてください）
使い方は
　=countC(セル範囲、指定文字）
となります。
※ セル範囲は、1行分の連続セル範囲とします。


Function countC(ByRef r As Range, ByRef s) As Long
Dim i As Long, j As Long, n As Long
Dim v

v = r.Rows(1).Cells.Value
For i = 1 To UBound(v, 2)
n = 0
For j = i To UBound(v, 2)
If v(1, j) = s Then n = n + 1 Else Exit For
Next j
v(1, i) = n
Next i

countC = Application.Max(v)
End Function

この回答へのお礼

分かりづらい質問内容なうえに、画像も適当で申し訳ありません。
やりたいことは、1か月の出勤日の中に、5連勤以上の勤務がそれぞれ何回あるかを数えたいというものでした。

教えていただいたコードを参考にさせていただきます。
ありがとうございました。

お礼日時：2023/12/25 13:23

No.1 回答者： yokomaya 回答日時： 2023/12/25 11:52

マクロくまなくても条件付き書式でできますよ。

ちょっと画像が小さすぎて座標が読めないんですけど
その出勤を記入するセル範囲全体を選択して
数式としては　仮に範囲がD2から始まるなら
=COUNTIF(D2:H2,"出勤")=5
これは5連勤の先頭セルを色付けします。
D2：H2は横に5個ならぶ範囲なので
6連勤の場合はD2:I2になります。

同様に6連勤、7連勤と色を変えて設定して
その判断の順序を長いものから先に判断するように並べます。

試して頂けませんか？

この回答へのお礼

丁寧な回答ありがとうございます。
やってみたらおっしゃる通りの結果が帰ってきました。

画像も荒くて申し訳ないです。
非常に厚かましいのですが、重ねて教えてもらってもいいでしょうか。

教えていただいた関数だと、範囲内に５連勤と４連勤があったら、間に空白があっても１０連勤とカウントされてしまうのですが、例えば使用している環境だとF5：AJ5に31日分の出欠が入っていて、F5：J5に出勤、K5:M5に休、N5:S5に出勤と入っていた場合、5連勤と6連勤があると思うのですが、これをAY5に5連勤あり、AZ5に6連勤ありと表示させるようなことはできますでしょうか。

お礼日時：2023/12/25 13:06