ExcelVBAのマクロについて。

Question

お世話になります。EXCELVBAマクロについてご教授ください。
添付表のような社員の出勤管理表を作成中です。
添付表のように出勤した日はセルに1から5を記入。空白セルは休日としています。
この空白から空白までのセルのカウント数が7以上の場合にセルをピンクに塗り潰すというマクロを下記のように作成してみました。

C列の最初の2行目から空白セルを検索してそのカウント数が7以上の場合にはピンクに塗り潰すところまではうまくいくのですが、最初に検索した空白セルを起点にしてそこから次の空白セルを検索し、
それを繰り返すマクロがわかりません。またＣ列の次の列への移行はFor Nextのネストを使えばよいと思いますが、そのマクロも教えていただくと有難いです。
どなたかご教授してくだされば助かります。宜しくお願いします。

Sub Blank()
    Dim lRow As Long
    Dim i, sB, NumB As Integer
    lRow = Range("A" & Rows.Count).End(xlUp).Row - 1
    With ActiveSheet
        With Range(Cells(2, 3), Cells(lRow, 3))
            For i = 2 To lRow
                sB = Range(Cells(2, 3), Cells(lRow, 3)).Find("").Row
                Range(Cells(i, 3), Cells(sB - 1, 3)).Select
                NumB = WorksheetFunction.Count(Range(Cells(i, 3), Cells(sB - 1, 3)))
                If NumB >= 7 Then
                    Range(Cells(i, 3), Cells(sB - 1, 3)).Interior.ColorIndex = 7   ' ピンク
                End If
            Next i
        End With
    End With
    
End Sub

zongai · Accepted Answer

コメント拝見しました。。 > 「7」は有給休暇なんですが、この「7」と空白を合わせた連勤チェックのマクロはどのようなものになるのでしょうか？「7」と空白を勤務日と除外する、ということであれば、 IFの条件を AND で追加します。 Sub nanarenkin() 　　Dim lRow As Long, lCol As Long　'最終行、最終列　　Dim i As Long, j As Long　　'行、列ループ用　　Dim cnt As Long '連勤カウント　　lRow = Cells(Rows.Count, 1).End(xlUp).Row - 1 　　lCol = Cells(1, Columns.Count).End(xlToLeft).Column 　　　　For j = 3 To lCol　 '3列目[C]から最終列まで　　　　cnt = 0 '連勤リセット　　　　For i = 2 To lRow　 '2行目から最終行まで　　　　　　If Cells(i, j) <> "" And Cells(i, j) <> 7 Then '空白と7以外なら　'【←ココが変わります】　　　　　　　　cnt = cnt + 1　 '連勤カウントプラス１　　　　　　　　If cnt >= 7 Then　　'7連勤以上なら　　　　　　　　　　Range(Cells(i - 6, j), Cells(i, j)).Interior.ColorIndex = 7 'ピンクで塗る！　　　　　　　　End If 　　　　　　Else 　　　　　　　　cnt = 0 '空白だったら連勤カウントリセット　　　　　　End If 　　　　Next 　　Next End Sub 他の方の回答も出てますので、ベストなものが見つかるといいですね。

Qchan1962 · Answer

＃６で回答した者です
Dim i As Long　は　Dim j As Long　です
確かめず投稿ごめんなさい
数字の5を有給（休み空白）扱いする場合は検索条件や比較条件を(変更）加えれば良いのですが、＃８zongai様が回答せれている処理方法の方が容易に改造できると思いますのでFindでの処理方法は割愛して＃６でのコンパイル・実行時エラーの訂正だけさせて頂きます。

めぐみん_ · Answer

やっぱ For Each は難しいですかね？

Sub megu()
Dim ra As Range
Dim rc As Range
Dim r As Range

Cells.Interior.ColorIndex = 0

Set ra = Range("C1").CurrentRegion
Set ra = ra.Offset(1, 2).Resize(ra.Rows.Count - 2, ra.Columns.Count - 2)

For Each rc In Intersect(ra, ra.Rows(1))

For Each r In Intersect(ra, rc.EntireColumn).SpecialCells(xlCellTypeConstants, xlNumbers).Areas

With r.Interior
.ColorIndex = IIf(r.Cells.Count > 6, 7, 0)
End With

Set ra = Nothing

End Sub

Qchan1962 · Answer

こんにちは

＞社員の出勤管理表
との事で連勤チェックと解釈しました。月初の連勤数を取得するなどして計算する必要がありそうですが、あまりコテコテにすると分からなくなりそうですが、空白セル間を塗りつぶす処理コードです。
sB = Range(Cells(2, 3), Cells(lRow, 3)).Find("").Row　Findが使用されていましたのでFindNextで作成しました

Sub Blank1()
Dim lRow As Long, lCol As Long
Dim i As Long, k As Long
Dim brought_forward As Integer
Dim r1 As Range, rng As Range
Dim tmpRng As Range, searchRng As Range
lCol = Cells(1, Columns.Count).End(xlToLeft).Column    '列方向
    lRow = Range("A" & Rows.Count).End(xlUp).Row - 1
    For j = 3 To lCol
    'brought_forward = 6 '繰り越し連勤6日の例 ここで取得
        Set searchRng = Range(Cells(2, j), Cells(lRow, j))
        Set rng = searchRng.Find("")    ' 最初はFindで検索
        If Not rng Is Nothing Then Set r1 = rng Else Exit For
        If Range(Cells(2, j), rng).Count + brought_forward > 7 Then
            Range(Cells(2, j), rng.Offset(-1)).Interior.ColorIndex = 6 + k
        End If
        Set tmpRng = rng
        Do While Not rng Is Nothing
            If Not r1 Is Nothing Then
                If Range(rng, r1).Count > 8 Then    '空白セルから空白セルまでのセルの数
                    Range(r1.Offset(1), rng.Offset(-1)).Interior.ColorIndex = 6 + k
                End If
                Set r1 = rng
            End If
    'FindNextで次を検索
            Set rng = searchRng.FindNext(rng)
            If rng.Address = tmpRng.Address Then
    '検索始めのセルアドレスで抜ける
                Exit Do
            End If
            k = k + 1
        Loop
        Cells(lRow + 2, j) = Range(Cells(lRow, j), r1).Count
        k = 0
        brought_forward = 0
        Set rng = Nothing
    Next j
End Sub

最終行下に月末の連勤日数が出力されるようにしましたので更新時に使えるかな？繰り越し連勤数を使う為の処理、変数を組み込んであります
色付けKは洒落です。消して下さい。

fujillin · Answer

こんにちは

条件付き書式でも可能な気がしますけれど・・
（条件付き書式だと未入力の際の空白も着色されてしまいますけれど、逐次入力するものなら、「本日迄」という条件を追加しておくことで不自然さもなくせると思います）

ご質問の件については、細部は適当ですがこんな感じでも可能かと。
ご参考までに。

Sub Sample()
Dim lastRow As Long, rw As Long, col As Long
Dim tmp As Long, cnt As Long

lastRow = Cells(Rows.Count, 1).End(xlUp).Row - 1

For col = 3 To Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(2, col), Cells(lastRow, col)).Interior.ColorIndex = xlNone
cnt = 0

For rw = 2 To lastRow
If Cells(rw, col).Value = "" Then
cnt = cnt + 1
If cnt = 1 Then tmp = rw
Else
If cnt > 6 Then Range(Cells(tmp, col), Cells(rw - 1, col)).Interior.ColorIndex = 7
cnt = 0
End If
Next rw
If cnt > 6 Then Range(Cells(tmp, col), Cells(lastRow, col)).Interior.ColorIndex = 7
Next col
End Sub

zongai · Answer

7連勤以上のチェックならと仮定すると…

Sub nanarenkin()
　　Dim lRow As Long, lCol As Long  '最終行、最終列
　　Dim i As Long, j As Long　　'行、列ループ用
　　Dim cnt As Long '連勤カウント

lRow = Cells(Rows.Count, 1).End(xlUp).Row - 1
　　lCol = Cells(1, Columns.Count).End(xlToLeft).Column
　　
　　For j = 3 To lCol   '3列目[C]から最終列まで
　　　　cnt = 0 '連勤リセット
　　　　For i = 2 To lRow   '2行目から最終行まで
　　　　　　If Cells(i, j) <> "" Then   '空白以外なら
　　　　　　　　cnt = cnt + 1   '連勤カウントプラス１
　　　　　　　　If cnt >= 7 Then　　'7連勤以上なら
　　　　　　　　　　Cells(i, j).Interior.ColorIndex = 7 'ピンクで塗る！
　　　　　　　　End If
　　　　　　Else
　　　　　　　　cnt = 0 '空白だったら連勤カウントリセット
　　　　　　End If
　　　　Next
　　Next
End Sub

仮に運用する場合、前月の最終連勤日数も翌月に持ち越さないとなりませんね。

t_fumiaki · Answer

各人の空白セルが7以上の場合だとは解りましたが、ピンクに塗り潰すセルはどこになるのでしょうか？？？

7個目以上のセル全部ですか？？　その回答あれば簡単です。

めぐみん_ · Answer

月末の変動による最終行『出勤』も移動するのかしないのかが気になりますね。
コード的には変動するような感じは受けますが確認のため。

あと With~End With に繋がるオブジェクト（RangeやCells）の頭にピリオド "." が付いていないのは漏れているって事なのかな？
⇒ActiveSheetを表示させた状態で実行するのならエラーにはならないでしょうけど。

zongai · Answer

想定しているマクロ実行結果イメージを添付できますか？

ExcelVBAのマクロについて。

コメント拝見しました。

＃６で回答した者です

やっぱ For Each は難しいですかね？

こんにちは

こんにちは

7連勤以上のチェックならと仮定すると…

各人の空白セルが7以上の場合だとは解りましたが、ピンクに塗り潰すセルはどこになるのでしょうか？？？

月末の変動による最終行『出勤』も移動するのかしないのかが気になりますね。

想定しているマクロ実行結果イメージを添付できますか？

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング