Excel VBA 値が空か0のとき発動する条件付き書式を設定する関数と消すときに記録して消すマクロとUsedRangeの注意点

値が空白か0

数式を使用

条件付き書式は、数式を使っている。（ほかに方法がだろうか？）
ActiveCellをA2とすると、A2が0か空白
OR(A2="",A2=0)
が真の時、A2を青くする。

削除するフラグのための式を追加

消すためのフラグという意味なので、2番めの条件付き書式の数式は、
AND(A2<>"",A2<>0,A2="ForchekFlag")
としている。ForChekFlagが入力されたらセルが黄色になるという式である。
この式自体は意味はない。Checkの単語もわざと間違えているのはそのためである。この式が入っているセルの条件付き書式を削除するという目的のために入れている。

Rangeの条件付き書式を消す時の注意点

Cells.FomatConditions.Delete
はシートのすべての条件付き書式が消えてしまう。公式のCellsの解説でも
Worksheet.Cells プロパティ (Excel)

ワークシートのすべてのセル (現在使用されていないセルも含む) を表す Range オブジェクトを返します。

となっている。
ところがUsedRangeだとA1のみか、値が入っている矩形の範囲の外にある条件付き書式は使用されていないセルになる。
今、B3に値が入っている。

実行すると

実はこのときUsedRangeはB3のみであると判定されている。

それではA1に値を入れる。すると、黄色で囲んだように、値が矩形の範囲入っている。

これは成功する。ただしD1や、A4に入っているものは消えない。

####構文
式.セル
式 Worksheet オブジェクトを表す変数。

' Sample 1
Dim ws As WorkSheet : Set ws = ActiveSheet
ws.Cells.Select

####注釈
Range の既定のメンバーではパラメーターを使用して Item プロパティの呼び出しを転送するため、Item の明示的な呼び出しの代わりに、セル キーワードの後に続けて行および列のインデックスを指定できます。
このプロパティでオブジェクト修飾子を指定しないコードを使用すると、アクティブ シートのすべてのセルを表す Range オブジェクトが返されます。

' Sample 2
Dim ws As WorkSheet : Set ws = ActiveSheet
ws.Activate
Cells.Select

つまり、Sample 1 , Sample2 は同じ意味になる。

Range.FormatConditions
Returns a FormatConditions collection that represents all the conditional formats for the specified range

指定した範囲 のすべての条件付き書式を表す FormatConditions コレクションを返します

FormatConditions.Delete メソッド (Excel)

そこで、指定したセル範囲（Range）の条件付きを削除する時だが、Selectを書かないとなぜか消えない時がある。
マクロの記録で得られる以下のコードを用いている。

Rng.Select
Selection.FormatConditions.Delete: DoEvents ' <<<< !!! ここで既存の条件つき書式は削除される

通常は以下のようにSelectを省略するが、この場合条件付き書式が1つしか消えない、全てが削除されないという現象が起きる。

Rng.FormatConditions.Delete: DoEvents ' <<<< !!! ここで既存の条件つき書式は削除されるはずだが、なぜか削除しきれない。

2番めから1番目に設定

これも常識だが、作るとSetPriorityをFirstにするので、最後から順に作る。
途中で変更するのはとても大変なので無理。
確かに、順番に作っても良い。
Home » ExcelVBA Rangeオブジェクト » 条件付き書式 » FormatConditionsのカッコ内数字の意味は？ - relief
つまりSetFirstpriorityの行を外せば1から順に登録される。
しかし、SetFirstPriorityを外すと、見た目ではわからないが、ログで吐き出されるPriorityが増えてしまう。

Priorityが増える

SetFirstPriorityの行を外し、1から条件付き書式を登録するようにする。
このとき、同じセルに条件付き書式を設定して削除する。
ということを繰り返すとPriorityが56とか変な数字になる。
以下のようなログである。

========== Sheet1 ==========
Sheet1	$D$1	MergeCells:=False	MergeArea:=$D$1
条件1	Priority:3	PTCondition:= False	StopIfTrue:True	xlNotBetween
		Formula1:="=OR($D$1="""",$D$1=0)"	
		AppliesTo:=$D$1
		InteriorColor:=15773696	TintAndShade:= 0	ColorIndex:=33	Interior.Pattern:=
		FontNameSize:	Color:=0	Bold:=	Italic:=
		NumberFormat:=
条件2	Priority:64	PTCondition:= False	StopIfTrue:True	xlNotBetween
		Formula1:="=AND($D$1<>"""",$D$1<>0,$D$1=""ForchekFlag"")"	
		AppliesTo:=$D$1
		InteriorColor:=65535	TintAndShade:= 0	ColorIndex:=6	Interior.Pattern:=
		FontNameSize:	Color:=	Bold:=	Italic:=
		NumberFormat:=
		Rng.FormatConditions.Delete

マクロを自動記録して吐き出されるSetfirstPriorityは実はこういう意味を持っているらしい。

全部記録削除の注意点

一応記録しながら全消しするようになっていてフラグは効いていない。
ところでUsedRangeで記録する際
Sheet2には何も入力しない状態でA2に条件付き書式を設定していると
UsedRangeはA1だけと判定され、A2はスルーされ記録されない。
現在この原因がわかっていないので、値が入力されている矩形の範囲に設定するものだけが記録される仕様である。
例えば、印刷領域外の値がなにもないところに設定すると、記録されないかもしれない。どうも使用されていないセルとして判定されているらしい。
このため、Cellsを使うようにしたが、こういう使い方は得てして不安定である。

  For Each Rng In ws.UsedRange '条件付き書式だけではUsedRangeではない

ここを

  For Each Rng In ws.Cells '条件付き書式だけではUsedRangeではない

または

  ws.Cells.Select
  ws.Cells.Select
  For Each Rng In Selection '条件付き書式だけではUsedRangeではない

ws.Cells.Selectは2回打たないと有効にならない時があるので、2回行っている。つまり、安定しない。

コメントアウト

記録されるか確認してから以下のコメントアウトを行うと、全削除するようになっている。
削除してはいけないものがある場合は、手動でクリアすること。
ここでCellsを使えばいいのかもしれないが、実験してみると、相当時間がかかってしまい、これも現実的ではなかった。

結合したセルは重複して出力（解消）

また、結合している分は結合しているセルの数だけ出力される。
例えばD5からF6までを結合させていると
結合セルは解消下。
また出力イメージを改善してみた。

Sheet1	$D$3	MergeCells:=False	MergeArea:=$D$3
条件1	Priority:3	PTCondition:= False	StopIfTrue:True	xlNotBetween
		Formula1:="=OR($D$3="""",$D$3=0)"	
		AppliesTo:=$D$3
		InteriorColor:=15773696	TintAndShade:= 0	ColorIndex:=33	Interior.Pattern:=
		FontNameSize:	Color:=0	Bold:=	Italic:=
		NumberFormat:=
条件2	Priority:4	PTCondition:= False	StopIfTrue:True	xlNotBetween
		Formula1:="=AND($D$3<>"""",$D$3<>0,$D$3=""ForchekFlag"")"	
		AppliesTo:=$D$3
		InteriorColor:=65535	TintAndShade:= 0	ColorIndex:=6	Interior.Pattern:=
		FontNameSize:	Color:=	Bold:=	Italic:=
		NumberFormat:=
		Rng.FormatConditions.Delete
Sheet1	$D$5	MergeCells:=True	MergeArea:=$D$5:$F$6
条件1	Priority:1	PTCondition:= False	StopIfTrue:True	xlNotBetween
		Formula1:="=OR($D$5="""",$D$5=0)"	
		AppliesTo:=$D$5
		InteriorColor:=15773696	TintAndShade:= 0	ColorIndex:=33	Interior.Pattern:=
		FontNameSize:	Color:=0	Bold:=	Italic:=
		NumberFormat:=
条件2	Priority:2	PTCondition:= False	StopIfTrue:True	xlNotBetween
		Formula1:="=AND($D$5<>"""",$D$5<>0,$D$5=""ForchekFlag"")"	
		AppliesTo:=$D$5:$F$6
		InteriorColor:=65535	TintAndShade:= 0	ColorIndex:=6	Interior.Pattern:=
		FontNameSize:	Color:=	Bold:=	Italic:=
		NumberFormat:=
		Rng.FormatConditions.Delete
====== Sheet End ======
Sheet2	$A$1	MergeCells:=False	MergeArea:=$A$1
条件1	Priority:1	PTCondition:= False	StopIfTrue:True	xlNotBetween
		Formula1:="=OR($A$1="""",$A$1=0)"	
		AppliesTo:=$A$1
		InteriorColor:=15773696	TintAndShade:= 0	ColorIndex:=33	Interior.Pattern:=
		FontNameSize:	Color:=0	Bold:=	Italic:=
		NumberFormat:=
条件2	Priority:2	PTCondition:= False	StopIfTrue:True	xlNotBetween
		Formula1:="=AND($A$1<>"""",$A$1<>0,$A$1=""ForchekFlag"")"	
		AppliesTo:=$A$1
		InteriorColor:=65535	TintAndShade:= 0	ColorIndex:=6	Interior.Pattern:=
		FontNameSize:	Color:=	Bold:=	Italic:=
		NumberFormat:=
		Rng.FormatConditions.Delete
====== Sheet End ======

結合セルについて

基本的に結合したセルの数だけ出力される。
これはMergeCells:=Trueで視覚的に判定してほしい。
また、これが一般的なのか、発生した理由は不明だが、結合しているセルまで出力すると、左上のセルだけが2番めの条件付き書式が出力されている。
ほかのセルは条件1だけが出力されている。
結合してからマクロで設定しているので、本来は2つはいってもおかしくない。
ともあれ、これも結合セルを見分けるポイントになりそうである。

ExcelのVBAのコード

ActiveCellに設定する

既存のセルの条件付き書式(FormatConditions)は削除される。
Stringを使っているのでExcel2002以降となる
指定した文字を繰り返す(String関数) - Moug
一応計算をとめて設定する。

Sub SetFmtCond()
Dim Rng As Range
Dim i As Long
Dim xlFc As FormatCondition
With Application
.DisplayAlerts = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set Rng = Range(ActiveCell.Address)
fnSetFormatConditions Rng
With Application
.DisplayAlerts = Not .DisplayAlerts
.Calculation = xlCalculationAutomatic ' 自動的に計算
.ScreenUpdating = Not .ScreenUpdating
End With
End Sub


Function fnSetFormatConditions(Rng As Range) As Boolean
' For Microsoft　Excel VBA

' Rangeに値が空白か0のときに青色になる条件付き書式を設定
' 注意：現在あるセルの条件付き書式はクリアする（追加で入ってわけがわからなくなるため）
' 2番めに消す対象となるフラグのためのダミーを入れる
' 成功したらTrueが返る
Dim xlFc As FormatCondition
Dim i As Long
On Error GoTo Err
Rng.Select
Selection.FormatConditions.Delete: DoEvents ' <<<< !!! ここで既存の条件つき書式は削除される

' Second

Rng.Select
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=And(" & Rng.Address & "<>""""," & Rng.Address & "<>0," & Rng.Address & "=""ForchekFlag"")"
    Selection.FormatConditions(1).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
    End With
Selection.FormatConditions(1).StopIfTrue = True

' First

Rng.Select
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=Or(" & Rng.Address & "=""""," & Rng.Address & "=0）"
    Rng.FormatConditions(2).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 15773696
        .TintAndShade = 0
    End With
Selection.FormatConditions(1).StopIfTrue = True
'成功するとTrueが返る
fnSetFormatConditions = True
Exit Function
Err:
If Err.Number <> 0 Then
Err.Clear
fnSetFormatConditions = False
End If
Exit Function
End Function

削除するマクロ

ブックが保存されている状態で、その保存されたフォルダに記録しながら消去する
Fontの設定等は多すぎるので完全に記録できない。あと罫線とかも無理だろう。
使いそうなものだけ、記録するようになっている。
値が入っていない場合にはそのシートのA1以外の条件付き書式は記録されない。
また、設定されていないプロパティはエラーになり、なった分は記録されない。
テキストの文字コードはUNICODE(UTF-16LE)を採用。
ファイル名の最初の3文字と記録時間でファイルを生成する。
連発するとファイルが増えるので注意。

削除を実行するときはコメントアウト

サンプルをそのまま使うと危ないコードのため、
'Cells.FormatConditions.Delete まずこの状態で動作を確認し、 の'を消して以下のように書き換えて保存してから実行すること。 Cells.FormatConditions.Delete`
これでそのシートの条件付き書式が削除される。
FormatConditions オブジェクト (Excel)
XlFormatConditionType 列挙 (Excel)
XlFormatConditionOperator
XlTimePeriods 列挙 (Excel)
現在の所、Typeしか有効に使えていない。

Sub DeleteAllWorksheetFormatConditions()
Dim wb As Workbook: Set wb = ThisWorkbook: wb.Activate
Dim ws As Worksheet
Dim fso As Object: Set fso = CreateObject("Scripting.FilesystemObject")
Dim ts, oFolder, sPath As String
Dim ar(1 To 7) As Variant, br() As Variant, tAr(0 To 9) As Variant, SelectionScopeAr(0 To 2), iArray As Long
Dim Rng As Range
Dim xlFc As FormatCondition, slFcs As FormatConditions, i As Long
iArray = 1
If wb.Saved = False Then MsgBox "Bookが保存されていません。保存してから実行してください。", vbOKOnly + vbCritical, "ブックが保存されていません": Exit Sub
Debug.Print wb.Name
'ReDim Preserve ar(1 To 7)
ar(1) = Array("xlBetween", "1", "間。2つの数式が指定されている場合にのみ使用できます。", "")
ar(2) = Array("xlNotBetween", "2", "次の値の間以外。2つの数式が指定されている場合にのみ使用できます。", "")
ar(3) = Array("xlEqual", "3", "等しい", "")
ar(4) = Array("xlNotEqual", "4", "等しくない", "")
ar(5) = Array("xlGreater", "5", "次の値より大きい", "")
ar(6) = Array("xlLess", "6", "次の値より小さい", "")
ar(7) = Array("xlGreaterEqual", "7", "以上", "")
ReDim Preserve br(1 To 15)
iArray = 1
br(iArray) = Array("xlCellValue", "1", "セルの値", ""): iArray = iArray + 1
br(iArray) = Array("xlExpression", "2", "演算", ""): iArray = iArray + 1
br(iArray) = Array("xlColorScale", "3", "カラースケール", ""): iArray = iArray + 1
br(iArray) = Array("xlDataBar", "4", "DataBar", ""): iArray = iArray + 1
br(iArray) = Array("xlTop10", "5", "上から10個の値", ""): iArray = iArray + 1
br(iArray) = Array("xlIconSet", "6", "アイコンセット", ""): iArray = iArray + 1 + 1
br(iArray) = Array("xlUniqueValues", "8", "一意の値", ""): iArray = iArray + 1
br(iArray) = Array("xlTextString", "9", "テキスト文字列", ""): iArray = iArray + 1
br(iArray) = Array("xlBlanksCondition", "10", "空白の条件", ""): iArray = iArray + 1
br(iArray) = Array("xlTimePeriod", "11", "期間", ""): iArray = iArray + 1
br(iArray) = Array("xlAboveAverageCondition", "12", "平均以上の条件", ""): iArray = iArray + 1
br(iArray) = Array("xlNoBlanksCondition", "13", "空白の条件なし", ""): iArray = iArray + 1
br(iArray) = Array("xlErrorsCondition", "16", "エラー条件", ""): iArray = iArray + 1
br(iArray) = Array("xlNoErrorsCondition", "17", "エラー条件なし", ""): iArray = iArray + 1
iArray = 0
tAr(iArray) = Array("xlToday", "0", "今日"): iArray = iArray + 1
tAr(iArray) = Array("xlYesterday", "1", "昨日"): iArray = iArray + 1
tAr(iArray) = Array("xlLast7Days", "2", "過去7日間"): iArray = iArray + 1
tAr(iArray) = Array("xlThisWeek", "3", "今週"): iArray = iArray + 1
tAr(iArray) = Array("xlLastWeek", "4", "先週"): iArray = iArray + 1
tAr(iArray) = Array("xlLastMonth", "5", "先月"): iArray = iArray + 1
tAr(iArray) = Array("xlTomorrow", "6", "明日"): iArray = iArray + 1
tAr(iArray) = Array("xlNextWeek", "7", "来週"): iArray = iArray + 1
tAr(iArray) = Array("xlNextMonth", "8", "来月"): iArray = iArray + 1
tAr(iArray) = Array("xlThisMonth", "9", "今月"): iArray = iArray + 1
' xlSelectionScope
iArray = 0
SelectionScopeAr(iArray) = Array("xlSelectionScope", "0", " 指定された選択基準に基づきます。"): iArray = iArray + 1
SelectionScopeAr(iArray) = Array("xlFieldsScope", 1, " 指定されたフィールドに基づきます。"): iArray = iArray + 1
SelectionScopeAr(iArray) = Array("xlDataFieldScope", 2, "指定されたフィールドのデータに基づきます。")

sPath = wb.Path & "\"
With Application
.DisplayAlerts = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set ts = fso.OpenTextFile(sPath & Left(wb.Name, 3) & "の 条件付き書式" & Format(Now, "yyyymmddhhmmss") & ".txt", 2, True, -1)
For Each ws In wb.Worksheets
Application.ScreenUpdating = True
ws.Activate: DoEvents
Application.ScreenUpdating = False
Debug.Print ws.Name
ts.writeline String(10, "=") & " " & ws.Name & " " & String(10, "=") & " UsedRange:=" & ws.UsedRange.Address
' UsedRangeのセルを判定
  For Each Rng In ws.UsedRange '条件付き書式だけではUsedRangeではない
'  ws.Cells.Select : Doevents
'  ws.Cells.Select : Doevents
'  For Each Rng In Selection 
'  For Each Rng In ws.Cells : Doevents '条件付き書式だけではUsedRangeではない
      Debug.Print Rng.Address
     If Rng.FormatConditions.Count > 0 Then
      If Rng.MergeCells = False Then
      ts.writeline ws.Name & vbTab & Rng.Address & vbTab & "MergeCells:=" & Rng.MergeCells & vbTab & "MergeArea:=" & Rng.MergeArea.Address
      ElseIf Rng.Address = Rng.MergeArea(1, 1).Address Then
      ts.writeline ws.Name & vbTab & Rng.Address & vbTab & "MergeCells:=" & Rng.MergeCells & vbTab & "MergeArea:=" & Rng.MergeArea.Address
      End If
      For i = 1 To Rng.FormatConditions.Count
      Set xlFc = Rng.FormatConditions.Item(i)
      On Error Resume Next
     ' ts.writeline ws.Name & vbTab & Rng.Address & vbTab & "MergeCells:=" & Rng.MergeCells & vbTab & "MergeArea:=" & Rng.MergeArea.Address
      If Rng.MergeCells Then
        If Rng.Address = Rng.MergeArea(1, 1).Address Then
        ts.writeline "条件" & i & vbTab & "Priority:" & xlFc.Priority & vbTab & "PTCondition:= " & xlFc.PTCondition & vbTab _
         & "StopIfTrue:" & xlFc.StopIfTrue & vbTab & ar(xlFc.Type)(0)
        ts.writeline String(2, vbTab) & "Formula1:=""" & Replace(xlFc.Formula1, Chr(34), String(2, Chr(34)), 1, -1, vbBinaryCompare) & """" & vbTab
        ts.writeline String(2, vbTab) & "Formula2:=""" & Replace(xlFc.Formula2, Chr(34), String(2, Chr(34)), 1, -1, vbBinaryCompare) & """" & vbTab
        ts.writeline String(2, vbTab) & "AppliesTo:=" & xlFc.AppliesTo.Address
        ts.writeline String(2, vbTab) & "InteriorColor:=" & xlFc.Interior.Color & vbTab & "TintAndShade:= " & xlFc.Interior.TintAndShade & vbTab _
          & "ColorIndex:=" & xlFc.Interior.ColorIndex & vbTab & "Interior.Pattern:=" & xlFc.Interior.Pattern
        ts.writeline String(2, vbTab) & "FontNameSize" & xlFc.Font.Name & ":" & xlFc.Font.Size & vbTab & "Color:=" & xlFc.Font.Color & vbTab _
          & "Bold:=" & xlFc.Font.Bold & vbTab & "Italic:=" & xlFc.Font.Italic
        ts.writeline String(2, vbTab) & "DateOperator:=" & tAr(xlFc.DateOperator)(0) & vbTab
        ts.writeline String(2, vbTab) & "NumberFormat:=" & xlFc.NumberFormat
        ts.writeline String(2, vbTab) & "Operator:=" & br(xlFc.Operator)(0)
        ts.writeline String(2, vbTab) & "ScopeType:=" & xlFc.ScopeType
        ts.writeline String(2, vbTab) & "Text:=" & xlFc.Text
        ts.writeline String(2, vbTab) & "TextOperator:=" & xlFc.TextOperator
      End If
      Else
      'ws.Name & vbTab & Rng.Address & vbTab & "MergeCells:=" & Rng.MergeCells & vbTab &
      ts.writeline "条件" & i & vbTab & "Priority:" & xlFc.Priority & vbTab & "PTCondition:= " & xlFc.PTCondition & vbTab _
        & "StopIfTrue:" & xlFc.StopIfTrue & vbTab & ar(xlFc.Type)(0)
      ts.writeline String(2, vbTab) & "Formula1:=""" & Replace(xlFc.Formula1, Chr(34), String(2, Chr(34)), 1, -1, vbBinaryCompare) & """" & vbTab
      ts.writeline String(2, vbTab) & "Formula2:=""" & Replace(xlFc.Formula2, Chr(34), String(2, Chr(34)), 1, -1, vbBinaryCompare) & """" & vbTab
      ts.writeline String(2, vbTab) & "AppliesTo:=" & xlFc.AppliesTo.Address
      ts.writeline String(2, vbTab) & "InteriorColor:=" & xlFc.Interior.Color & vbTab & "TintAndShade:= " & xlFc.Interior.TintAndShade & vbTab _
        & "ColorIndex:=" & xlFc.Interior.ColorIndex & vbTab & "Interior.Pattern:=" & xlFc.Interior.Pattern
      ts.writeline String(2, vbTab) & "FontNameSize" & xlFc.Font.Name & ":" & xlFc.Font.Size & vbTab & "Color:=" & xlFc.Font.Color & vbTab _
        & "Bold:=" & xlFc.Font.Bold & vbTab & "Italic:=" & xlFc.Font.Italic
      ts.writeline String(2, vbTab) & "DateOperator:=" & tAr(xlFc.DateOperator)(0) & vbTab
      ts.writeline String(2, vbTab) & "NumberFormat:=" & xlFc.NumberFormat
      ts.writeline String(2, vbTab) & "Operator:=" & br(xlFc.Operator)(0)
      ts.writeline String(2, vbTab) & "ScopeType:=" & xlFc.ScopeType
      ts.writeline String(2, vbTab) & "Text:=" & xlFc.Text
      ts.writeline String(2, vbTab) & "TextOperator:=" & xlFc.TextOperator
      End If
      Next i
     End If
  Next
ts.writeline "====== Sheet End ======"
'Cells.FormatConditions.Delete
Next
ts.Close  ' リストファイルを閉じる
With Application
.DisplayAlerts = Not .DisplayAlerts
.Calculation = xlCalculationAutomatic
.ScreenUpdating = Not .ScreenUpdating
End With
End Sub

特定のセルの条件付き書式を削除

Sub DeleteAllWorksheetFlagFormatConditions()
' For Microsoft Excel
' 削除するコードはコメントアウトして使用すること
' UsedRangeの条件付き書式のあるセル範囲のうち Forchekflagと記述がある条件付き書式があれば、セル範囲の条件付き書式を削除する。
Dim wb As Workbook: Set wb = ThisWorkbook: wb.Activate
Dim ws As Worksheet
Dim fso As Object: Set fso = CreateObject("Scripting.FilesystemObject")
Dim ts, oFolder, sPath As String
Dim ar(1 To 7) As Variant, br() As Variant, tAr(0 To 9) As Variant, SelectionScopeAr(0 To 2), iArray As Long
Dim Rng As Range
Dim xlFc As FormatCondition, slFcs As FormatConditions, i As Long
Dim delFlag As Boolean
iArray = 1
If wb.Saved = False Then MsgBox "Bookが保存されていません。保存してから実行してください。", vbOKOnly + vbCritical, "ブックが保存されていません": Exit Sub
Debug.Print wb.Name
'ReDim Preserve ar(1 To 7)
ar(1) = Array("xlBetween", "1", "間。2つの数式が指定されている場合にのみ使用できます。", "")
ar(2) = Array("xlNotBetween", "2", "次の値の間以外。2つの数式が指定されている場合にのみ使用できます。", "")
ar(3) = Array("xlEqual", "3", "等しい", "")
ar(4) = Array("xlNotEqual", "4", "等しくない", "")
ar(5) = Array("xlGreater", "5", "次の値より大きい", "")
ar(6) = Array("xlLess", "6", "次の値より小さい", "")
ar(7) = Array("xlGreaterEqual", "7", "以上", "")
ReDim Preserve br(1 To 15)
iArray = 1
br(iArray) = Array("xlCellValue", "1", "セルの値", ""): iArray = iArray + 1
br(iArray) = Array("xlExpression", "2", "演算", ""): iArray = iArray + 1
br(iArray) = Array("xlColorScale", "3", "カラースケール", ""): iArray = iArray + 1
br(iArray) = Array("xlDataBar", "4", "DataBar", ""): iArray = iArray + 1
br(iArray) = Array("xlTop10", "5", "上から10個の値", ""): iArray = iArray + 1
br(iArray) = Array("xlIconSet", "6", "アイコンセット", ""): iArray = iArray + 1 + 1
br(iArray) = Array("xlUniqueValues", "8", "一意の値", ""): iArray = iArray + 1
br(iArray) = Array("xlTextString", "9", "テキスト文字列", ""): iArray = iArray + 1
br(iArray) = Array("xlBlanksCondition", "10", "空白の条件", ""): iArray = iArray + 1
br(iArray) = Array("xlTimePeriod", "11", "期間", ""): iArray = iArray + 1
br(iArray) = Array("xlAboveAverageCondition", "12", "平均以上の条件", ""): iArray = iArray + 1
br(iArray) = Array("xlNoBlanksCondition", "13", "空白の条件なし", ""): iArray = iArray + 1
br(iArray) = Array("xlErrorsCondition", "16", "エラー条件", ""): iArray = iArray + 1
br(iArray) = Array("xlNoErrorsCondition", "17", "エラー条件なし", ""): iArray = iArray + 1
iArray = 0
tAr(iArray) = Array("xlToday", "0", "今日"): iArray = iArray + 1
tAr(iArray) = Array("xlYesterday", "1", "昨日"): iArray = iArray + 1
tAr(iArray) = Array("xlLast7Days", "2", "過去7日間"): iArray = iArray + 1
tAr(iArray) = Array("xlThisWeek", "3", "今週"): iArray = iArray + 1
tAr(iArray) = Array("xlLastWeek", "4", "先週"): iArray = iArray + 1
tAr(iArray) = Array("xlLastMonth", "5", "先月"): iArray = iArray + 1
tAr(iArray) = Array("xlTomorrow", "6", "明日"): iArray = iArray + 1
tAr(iArray) = Array("xlNextWeek", "7", "来週"): iArray = iArray + 1
tAr(iArray) = Array("xlNextMonth", "8", "来月"): iArray = iArray + 1
tAr(iArray) = Array("xlThisMonth", "9", "今月"): iArray = iArray + 1
' xlSelectionScope
iArray = 0
SelectionScopeAr(iArray) = Array("xlSelectionScope", "0", " 指定された選択基準に基づきます。"): iArray = iArray + 1
SelectionScopeAr(iArray) = Array("xlFieldsScope", 1, " 指定されたフィールドに基づきます。"): iArray = iArray + 1
SelectionScopeAr(iArray) = Array("xlDataFieldScope", 2, "指定されたフィールドのデータに基づきます。")
sPath = wb.Path & "\"
Set ts = fso.OpenTextFile(sPath & Left(wb.Name, 3) & "の 条件付き書式" & Format(Now, "yyyymmddhhmmss") & ".txt", 2, True, -1)
With Application
.DisplayAlerts = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
' 各ワークシートへ移動
For Each ws In wb.Worksheets
Application.ScreenUpdating = True
ws.Activate: DoEvents
Application.ScreenUpdating = False
ts.writeline String(10, "=") & " " & ws.Name & " " & String(10, "=")
' UsedRangeのセルを判定
  For Each Rng In ws.UsedRange '条件付き書式だけではUsedRangeではない
'      Debug.Print Rng.Address
     delFlag = False
     If Rng.FormatConditions.Count > 0 Then
      If Rng.MergeCells = False Then
      ts.writeline ws.Name & vbTab & Rng.Address & vbTab & "MergeCells:=" & Rng.MergeCells & vbTab & "MergeArea:=" & Rng.MergeArea.Address
      ElseIf Rng.Address = Rng.MergeArea(1, 1).Address Then
      ts.writeline ws.Name & vbTab & Rng.Address & vbTab & "MergeCells:=" & Rng.MergeCells & vbTab & "MergeArea:=" & Rng.MergeArea.Address
      End If
      For i = 1 To Rng.FormatConditions.Count
      Set xlFc = Rng.FormatConditions.Item(i)
      On Error Resume Next
     ' ts.writeline ws.Name & vbTab & Rng.Address & vbTab & "MergeCells:=" & Rng.MergeCells & vbTab & "MergeArea:=" & Rng.MergeArea.Address
      If Rng.MergeCells Then
        If Rng.Address = Rng.MergeArea(1, 1).Address Then
        ts.writeline "条件" & i & vbTab & "Priority:" & xlFc.Priority & vbTab & "PTCondition:= " & xlFc.PTCondition & vbTab _
         & "StopIfTrue:" & xlFc.StopIfTrue & vbTab & ar(xlFc.Type)(0)
        ts.writeline String(2, vbTab) & "Formula1:=""" & Replace(xlFc.Formula1, Chr(34), String(2, Chr(34)), 1, -1, vbBinaryCompare) & """" & vbTab
        If xlFc.Formula1 Like "*ForchekFlag*" And delFlag = False Then delFlag = True
        ts.writeline String(2, vbTab) & "Formula2:=""" & Replace(xlFc.Formula2, Chr(34), String(2, Chr(34)), 1, -1, vbBinaryCompare) & """" & vbTab
        If xlFc.Formula2 Like "*ForchekFlag*" And delFlag = False Then delFlag = True
        ts.writeline String(2, vbTab) & "AppliesTo:=" & xlFc.AppliesTo.Address
        ts.writeline String(2, vbTab) & "InteriorColor:=" & xlFc.Interior.Color & vbTab & "TintAndShade:= " & xlFc.Interior.TintAndShade & vbTab _
          & "ColorIndex:=" & xlFc.Interior.ColorIndex & vbTab & "Interior.Pattern:=" & xlFc.Interior.Pattern
        ts.writeline String(2, vbTab) & "FontNameSize" & xlFc.Font.Name & ":" & xlFc.Font.Size & vbTab & "Color:=" & xlFc.Font.Color & vbTab _
          & "Bold:=" & xlFc.Font.Bold & vbTab & "Italic:=" & xlFc.Font.Italic
        ts.writeline String(2, vbTab) & "DateOperator:=" & tAr(xlFc.DateOperator)(0) & vbTab
        ts.writeline String(2, vbTab) & "NumberFormat:=" & xlFc.NumberFormat
        ts.writeline String(2, vbTab) & "Operator:=" & br(xlFc.Operator)(0)
        ts.writeline String(2, vbTab) & "ScopeType:=" & SelectionScopeAr(xlFc.ScopeType)(0) & vbTab & SelectionScopeAr(xlFc.ScopeType)(1) & vbTab & SelectionScopeAr(xlFc.ScopeType)(2)
        ts.writeline String(2, vbTab) & "Text:=" & xlFc.Text
        ts.writeline String(2, vbTab) & "TextOperator:=" & xlFc.TextOperator
      End If
      Else
      'ws.Name & vbTab & Rng.Address & vbTab & "MergeCells:=" & Rng.MergeCells & vbTab &
      ts.writeline "条件" & i & vbTab & "Priority:" & xlFc.Priority & vbTab & "PTCondition:= " & xlFc.PTCondition & vbTab _
        & "StopIfTrue:" & xlFc.StopIfTrue & vbTab & ar(xlFc.Type)(0)
      ts.writeline String(2, vbTab) & "Formula1:=""" & Replace(xlFc.Formula1, Chr(34), String(2, Chr(34)), 1, -1, vbBinaryCompare) & """" & vbTab
      If xlFc.Formula1 Like "*ForCheckFlag*" And delFlag = False Then delFlag = True
      ts.writeline String(2, vbTab) & "Formula2:=""" & Replace(xlFc.Formula2, Chr(34), String(2, Chr(34)), 1, -1, vbBinaryCompare) & """" & vbTab
      If xlFc.Formula2 Like "*ForCheckFlag*" And delFlag = False Then delFlag = True
      ts.writeline String(2, vbTab) & "AppliesTo:=" & xlFc.AppliesTo.Address
      ts.writeline String(2, vbTab) & "InteriorColor:=" & xlFc.Interior.Color & vbTab & "TintAndShade:= " & xlFc.Interior.TintAndShade & vbTab _
        & "ColorIndex:=" & xlFc.Interior.ColorIndex & vbTab & "Interior.Pattern:=" & xlFc.Interior.Pattern
      ts.writeline String(2, vbTab) & "FontNameSize" & xlFc.Font.Name & ":" & xlFc.Font.Size & vbTab & "Color:=" & xlFc.Font.Color & vbTab _
        & "Bold:=" & xlFc.Font.Bold & vbTab & "Italic:=" & xlFc.Font.Italic
      ts.writeline String(2, vbTab) & "DateOperator:=" & tAr(xlFc.DateOperator)(0) & vbTab
      ts.writeline String(2, vbTab) & "NumberFormat:=" & xlFc.NumberFormat
      ts.writeline String(2, vbTab) & "Operator:=" & br(xlFc.Operator)(0)
            ts.writeline String(2, vbTab) & "ScopeType:=" & SelectionScopeAr(xlFc.ScopeType)(0) & vbTab & SelectionScopeAr(xlFc.ScopeType)(1) & vbTab & SelectionScopeAr(xlFc.ScopeType)(2)
      ts.writeline String(2, vbTab) & "Text:=" & xlFc.Text
      ts.writeline String(2, vbTab) & "TextOperator:=" & xlFc.TextOperator
      End If
      Next i
      If delFlag = True Then
        ts.writeline String(2, vbTab) & "Rng.FormatConditions.Delete":
        With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        wb.Activate
        ws.Select
        Rng.Select
        Debug.Print Rng.Address
'        Selection.FormatConditions.Delete: DoEvents  ' 安全のためコメント化しているので、確認後、コメントアウトすること。 セルにFlagのついた条件式書式があればここで削除
        delFlag = Not delFlag
        .DisplayAlerts = Not .DisplayAlerts
        .ScreenUpdating = Not .ScreenUpdating
        .Calculation = xlCalculationManual
       End With
’ このような形では削除できなかった
'        For i = 1 To Rng.FormatConditions.Count
'        Rng.FormatConditions.Item(i).Delete: DoEvents
'        Next
'        If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description: Err.Clear
       End If
     End If
  Next
ts.writeline "====== Sheet End ======": DoEvents
Next
ts.Close  ' リストファイルを閉じる
With Application
.DisplayAlerts = Not .DisplayAlerts
.Calculation = xlCalculationAutomatic
.ScreenUpdating = Not .ScreenUpdating
End With
End Sub

個人的な覚書

Redim Preserve ar(1 to n)の場合インデックスの最小値をずらすには、arはVariantでなければエラーになる。StringだからといってStringにしてはいけない。
次元とは列数だが、要素はインデックスで、行数に該当する。列数のように読むといけない。上記のar(1 to 7)は「行数」を決めていて、最初の行0行目とするか1行目とするかを決めている。
VBAで配列のインデックス・添字の最小値を1にずらす
また、Array関数を使う場合、Variantでなければならない。またVariantの場合Option Base 1を設定しても影響せず最小は0になる
Array関数の使い方・サンプル
表形式（要素が複数）あるときは、RedimでまずIndexの数（いわゆる行数）を決める。
または Dim ar(10)として、1から代入する方法もある。
また静的配列として Dim ar(1 To 7) As Variantを使うことも考えられる。この場合はRedimはいらない。
この1to7はつまり何行入るか、という意味になる。1行にいくつ入るか、という意味ではない。
VBA 配列 例えばこのページで言っている要素数とは行数のこと。1行あたりいくつ入るかではない。
代入はArray関数を使う。Splitはエラー。このためコンマ区切りになる
1行にいくつ入るかはArrayで変わる。
また、Redim(1 to n)としても1行の中の各要素のカウントは0からになる。
その代わり、定数の値と同じ行で合わせることで、返った値の定数を返すことができる。

配列から値を取り出す方法

この時、Array(1)(0)というように行、列をカッコを並べて記載する。上記のマクロでは1行目の1番めをさす。
ローカルウィンドウのような、Array(1,0)にはしない。また複数の値を一度には取り出せない。

使い方

従来、条件付き書式は同じものでもセルごとに設定するので、やたらコードが長くなっていたのだが、こうした空白かどうかチェックするものだけでも関数化すれば、コードが長くなることが防げる。