■xl2003：条件付き書式の色設定だけ残す

■xl2007：条件付き書式の色設定だけ残す では[PublishObjects.Addメソッド]を使っていますが、これは2003以前では無効です。
最後に
>他に、Wordを経由させる手法でも書式が固定されて取得できるようです。これは2003以前も共通でいけるような気がしますね。
>：
>機会あったらこちらを試行してもいいかも。
..と書いてるように、Word経由を試してみました。

前記事と同じで、まずはシートを追加し、条件付き書式を設定するコード。

Option Explicit

Sub pre()
　　With Sheets.Add.Range("B5:D10")
　　　　.Formula = "=INT(RAND()*100)"
　　　　.Value = .Value
　　　　With .FormatConditions
　　　　　　.Delete
　　　　　　.Add(xlCellValue, xlLess, 40).Interior.ColorIndex = 46
　　　　　　.Add(xlCellValue, xlLess, 80).Interior.ColorIndex = 45
　　　　　　.Add(xlCellValue, xlGreaterEqual, 80).Interior.ColorIndex = 44
　　　　End With
　　　　Call try(.Cells)
　　End With
End Sub
'-------------------------------------------------
Sub try(ByRef r As Range)
　　Dim rg As Range
　　Dim x　As Long
　　Dim y　As Long
　　Dim i　As Long

　　Set rg = r.Offset(, r.Columns.Count + 1).Item(1)
　　For x = 1 To r.Columns.Count
　　　　For y = 1 To r.Rows.Count
　　　　　　With rg.Offset(i)
　　　　　　　　.Value = r(y, x).Address(0, 0)
　　　　　　　　.Offset(, 1).Value = r(y, x).Value
　　　　　　　　.Offset(, 2).Value = r(y, x).Interior.Color
　　　　　　　　.Offset(, 3).Interior.Color = .Offset(, 2).Value
　　　　　　　　i = i + 1
　　　　　　End With
　　　　Next
　　Next
　　Set rg = Nothing
End Sub

"word.application"を経由して、表示された色だけ残し条件付き書式を解除するコード。

Sub test()
　　Dim wd As Object
　　Dim r　As Range

　　Set r = ActiveSheet.Range("B5:D10")
　　r.Item(1).Select
　　Set wd = CreateObject("word.application")
　　'wd.Visible = True
　　With wd.documents.Add
　　　　r.Copy
　　　　.content.pasteexceltable False, False, False
　　　　.tables(1).Range.Copy
　　　　r.Worksheet.PasteSpecial "HTML"
　　　　.Close False
　　End With
　　wd.Quit
　　Call try(r)

　　Set r = Nothing
　　Set wd = Nothing
End Sub

（結果）

一応、取れてるようです。
#ただし色をカスタマイズしてる場合は正確には取れないみたい :(