'標準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
'参照設定:【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