Excel条件付き書式をVBAで保存設定する【実務で活用できる】

Option Explicit
'条件付き書式設定取得
Sub GetFormatConditions()
    Dim i As Long
    Dim j As Long
    Dim tr As Long
    Dim re As Long
    Dim vFileName As Variant
    Dim sh As Worksheet
    Set sh = ThisWorkbook.ActiveSheet
    Dim wb As Workbook
    If sh.Range("A7").Value <> "" Then
        vFileName = sh.Range("A7").Value
    Else: vFileName = ""
    End If
    Application.ScreenUpdating = False      '画面表示抑制
    If chkWbOpened(vFileName) = False Then  '設定のファイルが開いているか調べる
        vFileName = Application.GetOpenFilename( _
                FileFilter:="Excelワークブック,*.xls?", _
                Title:="ファイルを指定して下さい", _
                MultiSelect:=False) '単一ファイルにする
        If vFileName = "" Then _
                MsgBox ("未選択のため処理を中止します！"): Exit Sub
        Set wb = Workbooks.Open(vFileName)      '選択ブックを開いてセット
    Else: Set wb = Workbooks(Dir(vFileName))    '開いているブックをセット
    End If
    sh.Activate
    If sh.Range("A9") <> "" Then
        re = MsgBox("シートに保存している設定を消去してよろしいですか？", _
                    vbExclamation + vbYesNo, "動作選択")
        If re = vbNo Then MsgBox "処理を中止します！": Exit Sub
        sh.Cells.ClearContents
    End If
    sh.Range("A7") = vFileName
    sh.Range("A9:M9") = Array("シート名", "範囲", _
                            "文字色", "文字太さ", "文字傾き", "セル背景色", _
                            "Type:タイプ", "Operater:条件", "式1", "式2", _
                            "LineStyle", "Weight", "ColorIndex")
    tr = 9
    For i = 1 To wb.Sheets.Count
        For j = 1 To wb.Sheets(i).Cells.FormatConditions.Count
            With wb.Sheets(i).Cells.FormatConditions.Item(j)
                tr = tr + 1
                sh.Cells(tr, 1).Value = wb.Sheets(i).name       'シート名
                sh.Cells(tr, 2).Value = .AppliesTo.Address      '範囲
                sh.Cells(tr, 3).Value = "'&H" & _
                        Right("000000" & Hex(.Font.Color), 6)   '文字色
                sh.Cells(tr, 4).Value = .Font.Bold              '文字太さ
                sh.Cells(tr, 5).Value = .Font.Italic            '文字傾
                sh.Cells(tr, 6).Value = "'&H" & _
                    Right("000000" & Hex(.Interior.Color), 6)   'セル背景色
                sh.Cells(tr, 7).Value = .Type                   'Type
                On Error Resume Next 'エラー回避用
                sh.Cells(tr, 8).Value = .Operator               '条件
                sh.Cells(tr, 9).Value = "'" & .Formula1         '式1
                sh.Cells(tr, 10).Value = "'" & .Formula2        '式2
                With .Borders                                   '経緯線の設定
                    sh.Cells(tr, 11).Value = .LineStyle
                    sh.Cells(tr, 12).Value = .Weight
                    sh.Cells(tr, 13).Value = "'&H" & Right("000000" & Hex(.Color), 6)
                End With
                On Error GoTo 0
            End With
        Next j
    Next i
    Application.ScreenUpdating = True       '画面表示要請を解除
    MsgBox "「" & Dir(vFileName) & "」 の条件付き書式を取得しました！"
End Sub

'書き出した条件付き書式設定の完全重複を削除する
Sub DelDuplicates()
    ActiveSheet.Range("A9").CurrentRegion.RemoveDuplicates _
            Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13), Header:=xlYes
End Sub

'セルに保存した条件付き書式設定をセット
Sub SetFormatConditions()
    Dim fc As FormatCondition
    Dim rn() As Variant
    Dim i As Long, s As Long
    Dim sh As Worksheet
    Set sh = ThisWorkbook.ActiveSheet
    Dim r As Range
    Set r = sh.Range("A10", sh.Cells(Rows.Count, 1).End(xlUp))
    If r.Count = 0 Then Exit Sub
    
    Dim vFileName As Variant
    Dim wb As Workbook
    Dim tgsh As Worksheet
    
    If sh.Range("A7").Value <> "" Then
        vFileName = sh.Range("A7").Value
    Else: vFileName = ""
    End If
    If chkWbOpened(vFileName) = False Then
        vFileName = Application.GetOpenFilename( _
                FileFilter:="Excelワークブック,*.xls?", _
                Title:="ファイルを指定して下さい", _
                MultiSelect:=False) 'true)
        If vFileName = "" Then _
                MsgBox ("未選択のため処理を中止します！"): Exit Sub
        Set wb = Workbooks.Open(vFileName)
    Else: Set wb = Workbooks(Dir(vFileName))
    End If
    sh.Activate
    Application.ScreenUpdating = False
    
    For s = 10 To r.Count + 10 - 1
        'セルから保存データを読み込む
        ReDim rn(1 To 13) As Variant
        For i = 1 To 13
            rn(i) = sh.Cells(s, i).Value
        Next i
        Set tgsh = wb.Sheets(rn(1))     'シート名
        '書式の設定（シート範囲、Type、条件、式1、式2）='Sheet1 (2)'!$N$1:$N$16
        Set fc = tgsh.Range(rn(2)).FormatConditions.Add( _
                            rn(7), rn(8), rn(9), rn(10))
        On Error Resume Next 'これ入れないとエラーで止まるので
        With fc
            With .Font                  'フォント
                .Color = rn(3)          '色
                .Bold = rn(4)           '太さ
                .Italic = rn(5)         '傾き
            End With
            .Interior.Color = rn(6)     '背景色
            With .Borders               '罫線
                .LineStyle = rn(11)     '線種
                .Weight = rn(12)        '太さ
                .Color = rn(13)         '色
            End With
        End With
    Next s
    MsgBox "「" & Dir(vFileName) & "」 に条件付き書式を設定しました！"
End Sub