[[20100926020906]]　『条件付書式で着色したセルの色を、書式を削除して』（がちゃぴん）　ページの最後に飛ぶ

『条件付書式で着色したセルの色を、書式を削除しても残したい』（がちゃぴん）
Windows Vista,Excel2007

いつも参考にしています。

条件付き書式で着色したセルもしくは文字の色を、条件付き書式を削除しても残す方法は無いでしょうか？

と言うのは、条件付書式を使ってセルを着色したエクセルを他人に渡すと、書式の条件が入力されたセルのデータを削除され、いつの間にか色が表示されなくなります。
例えば下記のような場合、B1のセルの色がA1と連動していると知らずにA1のデータを削除され、色が表示されなくなります。

 　 A    B
 1  1   red

 書式：A1=1の場合B1のセルの色が赤

自分が着色する時は、データ数が多いため条件付き書式が楽なのですが、他人にデータを渡す時に、条件付書式を削除しても色が固定化（と言っていいのか分かりませんが）される方法を探してます。

VBA等でも良いのですが、何か良い方法は無いでしょうか？

 根本的な疑問なのですが、
 ＞B1のセルの色がA1と連動していると知らずにA1のデータを削除され
 たときに、もとの色だけが残っている意味は何でしょう？

 例でいえば、A1 が 1 だからこそ B1 が赤くなっているわけで、A1 が 1 でなくなったら、
 B1 が赤である必然性がなくなりますが。

 A1 が 1 でなくなっても B1 が赤であってほしいのなら、条件付き書式ではなく
 最初から B1 を赤に設定しておけばいいのではないでしょうか。

 A1 を削除されては困る、ということなら、シートの保護とかの方策を考えるのが
 いいと思われます。

 （ちょっと）

説明不足ですみません。

例として記載しましたが、A1には色をつける為に計算式を入れており、計算式は社外秘です。

社外に対してデータを送付する際、計算式を残すことが出来ないため、A1を削除し無くてはいけません。

そのファイルは、社外からデータを追記してもらって返却して頂く必要がある為、保護出来ません。

やはり無理でしょうか？

 条件付き書式ではなくマクロで色を付けてしまえばよさそうに思いますが
 いかがでしょう？　(Hatch)
 A1=1　のとき　B1を赤にするという条件なら
If Range("a1").Value = 1 Then
    Range("a1").Offset(, 1).Interior.Color = RGB(255, 0, 0)
End If

 (追加)
条件付き書式で付けた書式を取得するのは面倒そうな感じです。
以下が参考になるかもしれません。
http://soudan1.biglobe.ne.jp/qa1455002.html

Hatchさん
ありがとうございます。

昨日マクロで一つずつセルに色付けしたのですが、データ量が膨大につきかなりの時間が掛ってしまいました。

条件付き書式をマクロで処理すると、セル範囲を選択すれば一回の処理の為時間が短縮出来る為、時間短縮になると思いましたが、書式を削除しても色だけ残すのはやはり無理そうですね。

 >条件付き書式で着色したセルもしくは文字の色を、条件付き書式を削除しても残す方法
 >は無いでしょうか？

 以前にも同様のご質問をされましたか？
 何故このようなことをしたいのか？　理由は、はっきりわかりませんが、
 そのときに作っておいたコードです。

 新規ブックにて試してください。

 標準モジュール（Module1）に　サンプルデータ作成コード

 '===============================================================
 Option Explicit
 Sub mk_sample()
    With Range("a1:a13")
       .FormatConditions.Delete
       With .Cells(1)
          .Select
          .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
                                                       Formula1:="15"
          .FormatConditions(1).Interior.ColorIndex = 3
          .Value = 15
       End With
       With .Cells(3)
          .Select
          .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
                     Formula1:="1"
          .FormatConditions(1).Font.ColorIndex = 3
          With .FormatConditions(1).Borders(xlLeft)
             .LineStyle = xlContinuous
             .Weight = xlThin
             .ColorIndex = xlAutomatic
          End With
          With .FormatConditions(1).Borders(xlRight)
             .LineStyle = xlContinuous
             .Weight = xlThin
             .ColorIndex = xlAutomatic
          End With
          With .FormatConditions(1).Borders(xlTop)
              .LineStyle = xlContinuous
              .Weight = xlThin
              .ColorIndex = xlAutomatic
          End With
          With .FormatConditions(1).Borders(xlBottom)
             .LineStyle = xlContinuous
             .Weight = xlThin
             .ColorIndex = xlAutomatic
          End With
          .Value = 1
       End With
       With .Cells(5)
          .Select
          .FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, _
                    Formula1:="=""x""", Formula2:="=""z"""
          .FormatConditions(1).Font.ColorIndex = 5
          .Value = "Y"
       End With
       With .Cells(7)
          .FormatConditions.Add Type:=xlCellValue, Operator:=xlNotBetween, _
                       Formula1:="=""a""", Formula2:="=""g"""
          .FormatConditions(1).Interior.ColorIndex = 7
          .Value = "p"
       End With
       With .Cells(9)
         .Select
         .FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
                           Formula1:="20"
         .FormatConditions(1).Font.ColorIndex = 3
         With .FormatConditions(1).Borders(xlLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 3
         End With
         With .FormatConditions(1).Borders(xlRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 3
         End With
         With .FormatConditions(1).Borders(xlTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 3
         End With
         With .FormatConditions(1).Borders(xlBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 3
         End With
         .Value = True
      End With
      With .Cells(11)
         .Select
         .FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _
                                Formula1:="20"
         .FormatConditions(1).Interior.ColorIndex = 39
         .Value = 19
      End With
      With .Cells(13)
         .Select
         .FormatConditions.Add Type:=xlExpression, Formula1:= _
                                 "=OR(A13=""A"",A13=""b"",A13=""C"")"
         With .FormatConditions(1).Font
            .Bold = True
            .Italic = False
            .ColorIndex = 3
         End With
        With .FormatConditions(1).Interior
           .ColorIndex = 8
           .PatternColorIndex = 3
           .Pattern = xlGray8
        End With
        .Value = "b"
      End With
    End With
 End Sub

 このmk_sampleを実行してください。

 アクティブシートのセルA1からA13のセル範囲の1行おきに条件付書式を
 設定し、その条件に合う値を入れてあります。

 次スレッドでこの条件付書式を削除し、条件付書式ではなく、実書式を設定する
 コードを提示します。

 ichinose

 コードです。
 別の標準モジュール（Module2）に

 '===================================================================
 Sub 条件付書式の書式移行()
    Dim rng As Range
    Dim g0 As Long
    Dim crng As Range
    Set rng = Selection
    For Each crng In rng
        With crng
           .Activate
           Call copyformat(.Cells(1))
           .FormatConditions.Delete
        End With
    Next
 End Sub
 '=================================================================
 Sub copyformat(ByVal rng As Range)
    Dim bd As Variant
    Dim g0 As Long
    Dim g1 As Long
    Dim g2 As Long
    Dim bb As Border
    Dim bdidx As Variant
    Dim fo As Variant
    Dim f1 As Variant
    Dim f2 As Variant
    Dim retcode As Long
    bdidx = Array(7, 10, 8, 9)
    bd = Array("Weight", "linestyle", "color")
    fo = Array("FontStyle", "Bold", "Italic", "Strikethrough", "Underline")
    With rng
       For g0 = 1 To .FormatConditions.Count
          retcode = 1
          With .FormatConditions(g0)
             If .Type = xlCellValue Then
                Select Case .Operator
                   Case 1
                     f1 = Evaluate(.Formula1)
                     f2 = Evaluate(.Formula2)
                     If StrComp(rng.Value, f1, vbTextCompare) >= 0 And StrComp(rng.Value, f2, vbTextCompare) <= 0 Then
                        retcode = 0
                     End If
                   Case 2
                     f1 = Evaluate(.Formula1)
                     f2 = Evaluate(.Formula2)
                     If StrComp(rng.Value, f1, vbTextCompare) >= 0 And StrComp(rng.Value, f2, vbTextCompare) <= 0 Then
                     Else
                        retcode = 0
                     End If
                   Case 3
                     f1 = Evaluate(.Formula1)
                     If StrComp(rng.Value, f1, vbTextCompare) = 0 Then
                        retcode = 0
                     End If
                   Case 4
                     f1 = Evaluate(.Formula1)
                     If StrComp(rng.Value, f1, vbTextCompare) <> 0 Then
                        retcode = 0
                     End If
                   Case 5
                     f1 = Evaluate(.Formula1)
                     If StrComp(rng.Value, f1, vbTextCompare) > 0 Then
                        retcode = 0
                     End If
                   Case 6
                     f1 = Evaluate(.Formula1)
                     If StrComp(rng.Value, f1, vbTextCompare) < 0 Then
                        retcode = 0
                     End If
                    Case 7
                     f1 = Evaluate(.Formula1)
                     If StrComp(rng.Value, f1, vbTextCompare) >= 0 Then
                        retcode = 0
                     End If
                   Case 8
                     f1 = Evaluate(.Formula1)
                     If StrComp(rng.Value, f1, vbTextCompare) <= 0 Then
                        retcode = 0
                     End If
                End Select
             Else
                If Evaluate(.Formula1) Then retcode = 0
             End If
             If retcode = 0 Then
                On Error Resume Next
                If Not IsNull(.Interior.Pattern) Then
                   rng.Interior.Pattern = .Interior.Pattern
                   rng.Interior.PatternColorIndex = .Interior.PatternColorIndex
                End If
                If Not IsNull(.Interior.ColorIndex) Then
                   rng.Interior.ColorIndex = .Interior.ColorIndex
                   rng.Interior.Color = .Interior.Color
                End If

                If Not IsNull(.Font.ColorIndex) Then
                   rng.Font.Color = .Font.Color
                   rng.Font.ColorIndex = .Font.ColorIndex
                End If
                For g1 = LBound(fo) To UBound(fo)
                   CallByName rng.Font, fo(g1), VbLet, CallByName(.Font, fo(g1), VbGet)
                Next
                For g1 = 1 To .Borders.Count
                   For g2 = LBound(bd) To UBound(bd)
                      If Not IsNull(CallByName(.Borders(g1), "Weight", VbGet)) Then
                         CallByName rng.Borders(bdidx(g1 - 1)), bd(g2), VbLet, CallByName(.Borders(g1), bd(g2), VbGet)
                      End If
                   Next
                Next
                On Error GoTo 0
             End If

          End With
       Next
    End With
 End Sub

 セル範囲A1:A13を選択し、選択した状態で、「条件付書式の書式移行」を実行してみてください。

 条件付書式は、削除され、同じ書式が実書式として、設定されます。

 試してみてください。

 ichinose

コメント返信：

[ 一覧(最新更新順) ]

[[20100926020906]] 『条件付書式で着色したセルの色を、書式を削除して』（がちゃぴん） ページの最後に飛ぶ

[[20100926020906]]　『条件付書式で着色したセルの色を、書式を削除して』（がちゃぴん）　ページの最後に飛ぶ