HOME > 即効テクニック > Excel VBA > 関数関連のテクニック > 文字色、背景色を条件に指定範囲の合計を出すユーザ定義関数

即効テクニック

関数関連のテクニック

文字色、背景色を条件に指定範囲の合計を出すユーザ定義関数

(Excel 97/2000)
サンプルマクロは、文字色、背景色をキーとして合計範囲のうち抽出的に合計を出す関数です。
Function Sample(合計範囲 As Range, _
    Optional 文字色指定セル As Range, _
    Optional 背景色指定セル As Range) As Double

    Dim myFlag As Byte, f As Boolean
    Dim myCell As Range
    Dim myFontCell As Range, myBackCell As Range
    Dim myFontClr() As Long, myBackClr() As Long
    Dim myCnt As Long

    Application.Volatile
    myFlag = 3
    If 文字色指定セル Is Nothing Then myFlag = myFlag - 2
    If 背景色指定セル Is Nothing Then myFlag = myFlag - 1
    
    If Int(myFlag / 2) = 1 Then
        For Each myFontCell In 文字色指定セル
            myCnt = myCnt + 1
            ReDim Preserve myFontClr(1 To myCnt)
            myFontClr(myCnt) = myFontCell.Font.Color
        Next
    End If
    myCnt = 0
    If myFlag Mod 2 = 1 Then
        For Each myBackCell In 背景色指定セル
            myCnt = myCnt + 1
            ReDim Preserve myBackClr(1 To myCnt)
            myBackClr(myCnt) = myBackCell.Interior.Color
        Next
    End If
    
    Set myRng = Nothing
    
    For Each myCell In 合計範囲
        f = False
        Select Case myFlag
            Case 0
                f = True
            Case 1
                For myCnt = 1 To 背景色指定セル.Cells.Count
                    If myCell.Interior.Color = myBackClr(myCnt) Then
                        f = True
                        Exit For
                    End If
                Next
            Case 2
                For myCnt = 1 To 文字色指定セル.Cells.Count
                    If myCell.Font.Color = myFontClr(myCnt) Then
                        f = True
                        Exit For
                    End If
                Next
            Case 3
                For myCnt = 1 To 背景色指定セル.Cells.Count
                    If myCell.Interior.Color = myBackClr(myCnt) Then _
                        Exit For
                Next
                If myCnt <= 背景色指定セル.Cells.Count Then
                    For myCnt = 1 To 文字色指定セル.Cells.Count
                        If myCell.Font.Color = myFontClr(myCnt) Then
                            f = True
                            Exit For
                        End If
                    Next
                End If
        End Select
        If f Then
            If myRng Is Nothing Then Set myRng = myCell _
            Else Set myRng = Union(myRng, myCell)
        End If
    Next
    
    Sample = Application.WorksheetFunction.Sum(myRng)

End Function