'条件付き書式による色を取得する関数 '【注意】対象セルのあるシートがアクティブなときだけ動作します。 'CColor(セル, 情報番号) ' '情報番号 ' 0: 条件付き書式の評価結果(戻り値 -1:なし, 0:不成立, 1-3:成立) ' 1: セルの色 インデックス ' 2: セルの色 RBG値 ' 3: フォント色 インデックス ' 4: フォント色 RBG値 Option Explicit Function CColor(セル, 情報番号) Dim fc As FormatCondition Dim c As Range Dim r As Range Dim ws As Worksheet Dim f1 As String Dim f2 As String Dim addr As String Dim ref As Long Dim cnt As Long Dim num As Long Dim bOK As Boolean On Error GoTo ErrorHandler Set c = セル(1) Set ws = c.Worksheet num = 情報番号 Select Case num Case 0, -1: CColor = -1 Case 1: CColor = c.Interior.ColorIndex Case 2: CColor = c.Interior.Color Case 3: CColor = c.Font.ColorIndex Case 4: CColor = c.Font.Color Case Else: CColor = CVErr(xlErrValue): Exit Function End Select If c.FormatConditions.Count = 0 Then Exit Function '参照形式の取得 ref = Application.ReferenceStyle If ref = xlA1 Then 'アクティブセルの取得 Set r = ActiveCell If r.Worksheet.Name <> c.Worksheet.Name Or _ r.Worksheet.Parent.Name <> c.Worksheet.Parent.Name Or _ r.Worksheet.Parent.Windows.Count > 1 Then If num <> -1 Then CColor = CVErr(xlErrNA): Exit Function End If End If 'アドレスの取得 addr = "=" & c.Address(, , ref) '条件成立のフラグの初期化 bOK = False For Each fc In c.FormatConditions cnt = cnt + 1 '条件の取得 f1 = """" f2 = """" On Error Resume Next f1 = fc.Formula1 f2 = fc.Formula2 On Error GoTo ErrorHandler If Left$(f1, 1) = "=" Then f1 = Mid$(f1, 2) If Left$(f2, 1) = "=" Then f2 = Mid$(f2, 2) If ref = xlA1 Then f1 = Application.ConvertFormula(f1, xlA1, xlR1C1, , r) f2 = Application.ConvertFormula(f2, xlA1, xlR1C1, , r) f1 = Application.ConvertFormula(f1, xlR1C1, xlA1, , c) f2 = Application.ConvertFormula(f2, xlR1C1, xlA1, , c) End If 'test for formula If num = -1 Then CColor = f1 & ", " & f2 Exit Function End If 'セル値条件の評価 If fc.Type = xlCellValue Then Select Case fc.Operator Case xlEqual bOK = ws.Evaluate(addr & "=(" & f1 & ")") Case xlNotEqual bOK = ws.Evaluate(addr & "<>(" & f1 & ")") Case xlGreater bOK = ws.Evaluate(addr & ">(" & f1 & ")") Case xlGreaterEqual bOK = ws.Evaluate(addr & ">=(" & f1 & ")") Case xlLess bOK = ws.Evaluate(addr & "<(" & f1 & ")") Case xlLessEqual bOK = ws.Evaluate(addr & "<=(" & f1 & ")") Case xlBetween bOK = ws.Evaluate(addr & ">=(" & f1 & ")") And ws.Evaluate(addr & "<=(" & f2 & ")") Case xlNotBetween bOK = ws.Evaluate(addr & "<(" & f1 & ")") Or ws.Evaluate(addr & ">(" & f2 & ")") End Select '数式の評価 ElseIf fc.Type = xlExpression Then On Error Resume Next If ws.Evaluate("=" & f1) Then bOK = Err.Number = 0 End If On Error GoTo ErrorHandler End If If bOK Then Select Case num Case 0: CColor = cnt Case 1: If Not IsNull(fc.Interior.ColorIndex) Then CColor = fc.Interior.ColorIndex Case 2: If Not IsNull(fc.Interior.Color) Then CColor = fc.Interior.Color Case 3: If Not IsNull(fc.Font.ColorIndex) Then CColor = fc.Font.ColorIndex Case 4: If Not IsNull(fc.Font.Color) Then CColor = fc.Font.Color End Select Exit Function End If Next If num = 0 Then CColor = 0 Exit Function ErrorHandler: CColor = CVErr(xlErrValue) Exit Function End Function Sub 条件付き書式を固定() Dim fc As FormatCondition Dim c As Range Dim ws As Worksheet Dim f1 As String Dim f2 As String Dim addr As String Dim b As Variant Dim ba As Variant Dim ref As Long Dim bOK As Boolean Dim bDel As Long Dim oFont As Font Dim oInterior As Interior Dim oBorder As Border On Error GoTo ErrorHandler If MsgBox("条件付き書式を通常のセル書式に変更します。" & vbNewLine & _ "元には戻せません。実行しますか？", _ vbExclamation Or vbOKCancel Or vbDefaultButton2) <> vbOK Then Exit Sub bDel = MsgBox("書式変更後に条件付き書式をクリアしますか？", _ vbExclamation Or vbYesNoCancel Or vbDefaultButton2) If bDel = vbCancel Then Exit Sub Application.ScreenUpdating = False '罫線インデックスの初期値 ba = Array(xlLeft, xlRight, xlTop, xlBottom) '参照形式の取得 ref = Application.ReferenceStyle Set ws = ActiveSheet For Each c In Selection '結合セルの場合、第1セルだけを処理する If c.MergeCells Then If c.Address <> c.MergeArea(1).Address Then GoTo Continue End If 'アドレスの取得 addr = "=" & c.Address(, , ref) 'セルをアクティブにする c.Activate '条件成立のフラグの初期化 bOK = False For Each fc In c.FormatConditions '条件の取得 f1 = """" f2 = """" On Error Resume Next f1 = fc.Formula1 f2 = fc.Formula2 On Error GoTo ErrorHandler If Left$(f1, 1) = "=" Then f1 = Mid$(f1, 2) If Left$(f2, 1) = "=" Then f2 = Mid$(f2, 2) 'セル値条件の評価 If fc.Type = xlCellValue Then Select Case fc.Operator Case xlEqual bOK = ws.Evaluate(addr & "=(" & f1 & ")") Case xlNotEqual bOK = ws.Evaluate(addr & "<>(" & f1 & ")") Case xlGreater bOK = ws.Evaluate(addr & ">(" & f1 & ")") Case xlGreaterEqual bOK = ws.Evaluate(addr & ">=(" & f1 & ")") Case xlLess bOK = ws.Evaluate(addr & "<(" & f1 & ")") Case xlLessEqual bOK = ws.Evaluate(addr & "<=(" & f1 & ")") Case xlBetween bOK = ws.Evaluate(addr & ">=(" & f1 & ")") And ws.Evaluate(addr & "<=(" & f2 & ")") Case xlNotBetween bOK = ws.Evaluate(addr & "<(" & f1 & ")") Or ws.Evaluate(addr & ">(" & f2 & ")") End Select '数式の評価 ElseIf fc.Type = xlExpression Then On Error Resume Next If ws.Evaluate("=" & f1) Then bOK = Err.Number = 0 End If On Error GoTo ErrorHandler End If If bOK Then 'フォントの設定 Set oFont = c.MergeArea.Font With fc.Font If Not IsNull(.Bold) Then oFont.Bold = .Bold If Not IsNull(.Italic) Then oFont.Italic = .Italic If Not IsNull(.Underline) Then oFont.Underline = .Underline If Not IsNull(.ColorIndex) Then oFont.ColorIndex = .ColorIndex If Not IsNull(.Strikethrough) Then oFont.Strikethrough = .Strikethrough End With '塗りつぶしの設定 Set oInterior = c.MergeArea.Interior With fc.Interior If Not IsNull(.ColorIndex) Then oInterior.ColorIndex = .ColorIndex If Not IsNull(.Pattern) Then oInterior.Pattern = .Pattern If Not IsNull(.PatternColorIndex) Then oInterior.PatternColorIndex = .PatternColorIndex End With '罫線の設定 For Each b In ba Set oBorder = c.MergeArea.Borders(b) With fc.Borders(b) If Not IsNull(.LineStyle) Then oBorder.LineStyle = .LineStyle If Not IsNull(.Weight) Then oBorder.Weight = .Weight If Not IsNull(.ColorIndex) Then oBorder.ColorIndex = .ColorIndex End With Next Exit For End If Next Continue: Next '条件付き書式の削除 If bDel = vbYes Then Selection.FormatConditions.Delete Application.ScreenUpdating = True Exit Sub ErrorHandler: Application.ScreenUpdating = True MsgBox Err.Description, vbExclamation Exit Sub End Sub