■RegisterClipboardFormatA("HTML Format")

'標準Module
'参照設定:【Microsoft Forms 2.0 Object Library】
Option Explicit
Option Private Module

Declare Function CloseClipboard Lib "user32.dll" () As Long

Declare Function OpenClipboard Lib "user32.dll" ( _
　　　　　　　　　　　　　　　 ByVal hwnd As Long) As Long

Declare Function GetClipboardData Lib "user32.dll" ( _
　　　　　　　　　　　　　　　　　ByVal wFormat As Long) As Long

Declare Function RegisterClipboardFormatA Lib "user32.dll" ( _
　　　　　　　　　　　　　　　　　　　　　ByVal lpszFormat As String) As Long

Declare Function GlobalSize Lib "kernel32.dll" ( _
　　　　　　　　　　　　　　ByVal hMem As Long) As Long

Declare Function GlobalLock Lib "kernel32.dll" ( _
　　　　　　　　　　　　　　ByVal hMem As Long) As Long

Declare Function GlobalUnlock Lib "kernel32.dll" ( _
　　　　　　　　　　　　　　　ByVal hMem As Long) As Long

Declare Sub RtlMoveMemory Lib "kernel32.dll" ( _
　　　　　　　　　　　　　ByVal hpvDest As Any, _
　　　　　　　　　　　　　ByVal hpvSource As Any, _
　　　　　　　　　　　　　ByVal cbCopy As Long)
'-------------------------------------------------
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
　　　　chk .Cells
　　　　Stop
　　　　test .Cells
　　　　chk .Cells
　　End With
End Sub
'-------------------------------------------------
Sub test(r As Range)
　　Dim buf As String
　　Dim mem As Long
　　Dim sz　As Long
　　Dim lk　As Long

　　r.Copy
　　OpenClipboard 0&
　　mem = GetClipboardData(RegisterClipboardFormatA("HTML Format"))
　　CloseClipboard
　　If mem = 0 Then Exit Sub
　　sz = GlobalSize(mem)
　　lk = GlobalLock(mem)
　　buf = String(sz + 1, vbNullChar)
　　RtlMoveMemory buf, lk, sz
　　GlobalUnlock mem
　　buf = Left$(buf, InStr(buf, vbNullChar) - 1)
　　buf = Replace$(buf, "mso-ignore:style;", "") '■2007,2010では無くてもOK
　　With New DataObject
　　　　.Clear
　　　　.SetText buf
　　　　.PutInClipboard
　　End With
　　r.Worksheet.Paste r
End Sub
'-------------------------------------------------
Sub chk(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

#『条件付き書式の色設定だけ残す』..また？..orz
#一応Ver.2000,2003,2007,2010で動作確認。（winXP）
#でもWin32APIについての理解はも浅い私ですから
#試す場合は自己責任でお願いします。

#参考にさせて頂いたサイト
http://homepage2.nifty.com/kmado/kvba.htm（E03M121）
http://www.tsware.jp/study/vol1/kaibo_15.htm