[[20171030194456]]　『複数条件を満たすセルの個数だけ引き算を実行した』（カレンダー）　ページの最後に飛ぶ

『複数条件を満たすセルの個数だけ引き算を実行したい』（カレンダー）

お世話になります。

業務にて週末の勤務の回数と出張の回数をエクセルの表にまとめております。
その表の中で，週末に出張した場合には，出張だけにカウントされるよう数式を作りたいのですが，
うまくいかず困っております。

出張を除いた週末勤務回数を計算させるのに，単純に（週末勤務の回数―出張の回数）としてしまうと，
例えば，出張が１回あっただけの人に関しては，週末勤務の回数が－１回となり，(週末0回-出張1回=週末-1回)
出張１回，週末勤務１回の人に関しては，週末勤務の回数が０回となってしまいます。(週末1回-出張1回=週末0回)

ですので，週末に出張をした場合を除いた週末勤務の回数を計算させるには，
例えば，週末勤務の回数を数え，週末勤務と出張の２つの条件を満たすセルの個数だけ，引き算を実行する，
という数式が必要になると思うのですが，どの関数を使うのか分からず，それゆえ，式も立てられずにおります。

ちなみに，週末勤務を数えるのには，該当するセルの文字を赤に染めているため，
ユーザー定義関数CountSyuumatu(範囲，数字による色の指定)を使用し，
出張を数えるのには，該当するセルを緑色に染めているため，
ユーザー定義関数CountColor(範囲，基準となる色のセル)を使用しております。

不要かもしれませんが，使用しておりますユーザー定義関数を以下に記載させて頂きます。

お知恵を拝借できればと思います。よろしくお願い致します。

Public Function CountSyuumatsu(adrs, clr)

        Dim sm As Variant, cv As Variant, fci As Integer, ad As Range
        sm = 0
        For Each ad In adrs
            fci = ad.Font.ColorIndex
            If fci = clr Then
                 cv = ad.Value                      '処理を追加
                If Not IsEmpty(cv) Then sm = sm + 1 '判定を追加
            End If
        Next
        CountSyuumatsu = sm
    End Function

Function CountColor(計算範囲, 条件色セル)

    CountColor = 0
    For y = 1 To 計算範囲.Columns.Count
        For x = 1 To 計算範囲.Rows.Count
            If 計算範囲.Rows(x).Columns(y).Interior.ColorIndex = 条件色セル.Interior.ColorIndex Then
                CountColor = CountColor + 1
            End If
        Next
    Next
End Function

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

色でしか週末かそうか判定できないのでしょうか。
日付情報は、どこにもないのですか。

もしそうなら、背景が緑で、文字が赤を数える関数を作ればよいのでは。
でもユーザー定義関数を使うくらいなら、マクロで結果だけ出すのはだめなのでしょうか。

（マナ） 2017/10/30(月) 21:13

 週末勤務は赤文字で表現
 出張は(週末・平日関係なく)緑で塗りつぶし
 　　　↓
 週末に出張だったら赤文字に緑で塗りつぶし

 これは結局「赤文字がある」または「緑で塗りつぶし」のセルをカウント
 という事になるのでしょうか・・・?

 であれば、
 現在お使いの２つのFunctionをひとまとめにしてしまえば済むのではないでしょうか?

 # 一応、前回からの「乗りかかった船」ということで、やっつけですがサンプルコードを書いておきます。が、
 # 余計なお世話かもですが、もし大切な勤怠情報なのであれば、色で管理するのは"かなり"抵抗を感じますよ...?

    Public Function 色カウント(計算範囲 As Range, 条件フォント色セル As Range, 条件塗りつぶし色セル As Range) As Long
        Dim FColorID As Long, IColorID As Long, c As Range, rUsed As Range
    '    Application.Volatile
        With 計算範囲.Worksheet
            Set rUsed = .UsedRange
            Set rUsed = .Range(.Cells(1, 1), rUsed.Item(rUsed.Cells.Count))
        End With
        Set rUsed = Intersect(計算範囲, rUsed)
        If rUsed Is Nothing Then Exit Function
        For Each c In rUsed.Cells
            FColorID = Empty
            IColorID = Empty
            On Error Resume Next
            FColorID = c.Font.ColorIndex
            IColorID = c.Interior.ColorIndex
            On Error GoTo 0
            If IColorID = 条件塗りつぶし色セル.Interior.ColorIndex Then
                色カウント = 色カウント + 1
            ElseIf FColorID = 条件フォント色セル.Font.ColorIndex Then
                If Not IsEmpty(c.Value) Then 色カウント = 色カウント + 1
            End If
        Next
    End Function

（白茶） 2017/10/30(月) 21:36

マナ様、白茶様、ご回答をありがとうございます。

言葉が足らず、うまく伝えられていなかったようです。
どう式を立てたらいいのか悩んだのですが、マナ様がおっしゃっている通り、
赤文字「かつ」緑色塗りつぶし、両方の条件を満たす場合だけに数える関数を知れば、
式を立てられることに気が付かされました。
週末（赤文字）ー週末かつ出張（赤文字かつ緑塗りつぶし）＝出張抜きの週末の回数

せっかく関数をつくって頂いたのですが、両方をくっつけたものですと、
赤文字だけのときも、緑塗りつぶしだけのときも数えてしまい、上記の引き算ができないようです。

もっと考えをまとめてから質問をさせて頂くべきでした。
大変恐縮ですが、赤文字かつ緑塗りつぶしの場合だけに数える関数をご教示願えないでしょうか。

勤怠管理の在り方につきましては、下っ端の私が何かを言える立場にはないのですが、
いままでは、染めたセルや、色のついた文字を一つずつ、人力で数えていたようです。
人力でなくなるだけミスが減り、改善されるかなと。。。

お手数ですが、よろしくお願い致します。
（カレンダー） 2017/10/31(火) 02:09

 >出張を除いた週末勤務回数
 ありゃ、すみません。そうでしたね

    Rem Font.ColorIndexとInterior.ColorIndex両方が[条件色セル]と一致する空白以外のセル数
    Public Function 色カウント2(計算範囲 As Range, 条件色セル As Range) As Long
        Dim FColorID As Long, IColorID As Long, c As Range, rUsed As Range
    '    Application.Volatile
        With 計算範囲.Worksheet
            Set rUsed = .UsedRange
            Set rUsed = .Range(.Cells(1, 1), rUsed.Item(rUsed.Cells.Count))
        End With
        Set rUsed = Intersect(計算範囲, rUsed)
        If rUsed Is Nothing Then Exit Function
        For Each c In rUsed.Cells
            IColorID = c.Interior.ColorIndex
            FColorID = Empty
            On Error Resume Next
            FColorID = c.Font.ColorIndex
            On Error GoTo 0
            If IColorID = 条件色セル.Interior.ColorIndex And FColorID = 条件色セル.Font.ColorIndex Then
                If Not IsEmpty(c.Value) Then 色カウント2 = 色カウント2 + 1
            End If
        Next
    End Function

 >下っ端の私が何かを言える立場にはない
 そうなのですか。それは残念です...
 個人的には「何としても避けたい」部類に当てはまるケースなんですけどねぇ
 (会計に引き継がれるような重要性の高い集計であれば、の話ですよ?)

 もしホントにこれで勤怠管理してるんなら、
 ・環境や人が変われば色の認識も変わる(ColorIndexとColorは別物。「自動」と「黒」も別物)
 ・再計算洩れによる集計誤りのリスクが高い → やはり結果確認が必要になる → 結局人力で数えるのと手間変わらず
 ・今後の仕様変更への対応が煩雑になる → 引いては、業務引継ぎの場面で面倒なことになる

 といった「今のやり方は、本来なら回避できるハズの不都合が内包されてますよ」程度の認識は
 上席の方に持って貰うべきなんじゃないかな～と思います。
 まぁ老婆心はこれくらいにしといて、

 ちょっと別の集計が必要になった時とか今後の為にも、という意味で
 機能を後退(分散?)させて組み立てた方が、応用し易いのかなぁとも思って
 幾つか「余計なもの」を作ってみました。
 ご参考迄～

    Rem [計算範囲]のFont.ColorIndexとInterior.ColorIndex両方が[条件色セル]と一致する範囲のセル数を返す
    Function 指定色セル数(計算範囲 As Range, 条件色セル As Range) As Long
        Dim R As Range
        Set R = 指定色範囲(計算範囲, 条件色セル)
        If Not R Is Nothing Then 指定色セル数 = R.Cells.Count
    End Function
    Rem [計算範囲]のFont.ColorIndexとInterior.ColorIndex両方が[条件色セル]と一致する範囲への参照を返す
    Rem (「=COUNT(指定色範囲(計算範囲,条件色セル))」とか「=SUM(指定色範囲(計算範囲,条件色セル))」という使い方を想定)
    Function 指定色範囲(計算範囲 As Range, 条件色セル As Range) As Range
        Dim R1 As Range, R2 As Range
        Set R1 = GetAreasByFontColorIndex(計算範囲, 条件色セル.Font.ColorIndex)
        Set R2 = GetAreasByInteriorColorIndex(計算範囲, 条件色セル.Interior.ColorIndex)
        If Not R1 Is Nothing And Not R2 Is Nothing Then Set 指定色範囲 = Intersect(R1, R2)
    End Function
    Rem [計算範囲]のFont.ColorIndexとInterior.ColorIndex両方が[条件色セル]と一致する範囲のCOUNTA結果を返す
    Rem (「=COUNTA(指定色範囲(計算範囲,条件色セル))」とは違って、該当セルがなかった場合はゼロを返す)
    Function 指定色COUNTA(計算範囲 As Range, 条件色セル As Range) As Long
        Dim R As Range
        Set R = 指定色範囲(計算範囲, 条件色セル)
        If Not R Is Nothing Then Set R = GetAreasExceptBlankCells(R) '←空白セルを除外
        If Not R Is Nothing Then 指定色COUNTA = R.Cells.Count
    End Function
    Rem 内部処理:[rFrom]内のFont.ColorIndexが[idFontColor]と一致する範囲への参照を返す
    Private Function GetAreasByFontColorIndex(rFrom As Range, idFontColor As Long) As Range
        Dim aColorId As Long, c As Range, rUsed As Range
    '    Application.Volatile
        With rFrom.Worksheet
            Set rUsed = .UsedRange
            Set rUsed = .Range(.Cells(1, 1), rUsed.Item(rUsed.Cells.Count))
        End With
        Set rUsed = Intersect(rFrom, rUsed)
        If rUsed Is Nothing Then Exit Function
        For Each c In rUsed.Cells
            aColorId = Empty
            On Error Resume Next
            aColorId = c.Font.ColorIndex
            On Error GoTo 0
            If aColorId = idFontColor Then
                If GetAreasByFontColorIndex Is Nothing Then
                    Set GetAreasByFontColorIndex = c
                Else
                    Set GetAreasByFontColorIndex = Union(GetAreasByFontColorIndex, c)
                End If
            End If
        Next
    End Function
    Rem 内部処理:[rFrom]内のInterior.ColorIndexが[idInteriorColor]と一致する範囲への参照を返す
    Private Function GetAreasByInteriorColorIndex(rFrom As Range, idInteriorColor As Long) As Range
        Dim aColorId As Long, c As Range, rUsed As Range
    '    Application.Volatile
        With rFrom.Worksheet
            Set rUsed = .UsedRange
            Set rUsed = .Range(.Cells(1, 1), rUsed.Item(rUsed.Cells.Count))
        End With
        Set rUsed = Intersect(rFrom, rUsed)
        If rUsed Is Nothing Then Exit Function
        For Each c In rUsed.Cells
            If c.Interior.ColorIndex = idInteriorColor Then
                If GetAreasByInteriorColorIndex Is Nothing Then
                    Set GetAreasByInteriorColorIndex = c
                Else
                    Set GetAreasByInteriorColorIndex = Union(GetAreasByInteriorColorIndex, c)
                End If
            End If
        Next
    End Function
    Rem 内部処理:[rFrom]内の空白セルを除外した範囲(長さゼロの文字列セルは除外されない)への参照を返す
    Private Function GetAreasExceptBlankCells(rFrom As Range) As Range
        Dim c As Range
        For Each c In rFrom.Cells
            If Not IsEmpty(c.Value) Then
                If GetAreasExceptBlankCells Is Nothing Then
                    Set GetAreasExceptBlankCells = c
                Else
                    Set GetAreasExceptBlankCells = Union(GetAreasExceptBlankCells, c)
                End If
            End If
        Next
    End Function

（白茶） 2017/10/31(火) 17:10

白茶様

返信とお礼が遅れてしまい、申し訳ありません。

自分でも調べしらべ、少しいじってみて、動くものができたのですが、
頂いたもののほうが基準となるセルが一つで済み、とても便利です。
また、追加での関数をありがとうございます。
参考にさせて頂きます。

ありがとうございました。
（カレンダー） 2017/11/02(木) 01:09

コメント返信：

[ 一覧(最新更新順) ]

[[20171030194456]] 『複数条件を満たすセルの個数だけ引き算を実行した』（カレンダー） ページの最後に飛ぶ

[[20171030194456]]　『複数条件を満たすセルの個数だけ引き算を実行した』（カレンダー）　ページの最後に飛ぶ