| |
データバーやアイコンセット以外の単純単色の条件付き書式だったら。
..力技的ですが:D
'■標準Module
'■参照設定:[Microsoft Forms 2.0 Object Library]
Option Explicit
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function OpenClipboard Lib "user32.dll" ( _
ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" ( _
ByVal wFormat As Long) As Long
Private Declare Function RegisterClipboardFormatA Lib "user32.dll" ( _
ByVal lpszFormat As String) As Long
Private Declare Function GlobalSize Lib "kernel32.dll" ( _
ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" ( _
ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" ( _
ByVal hMem As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" ( _
ByVal hpvDest As Any, _
ByVal hpvSource As Any, _
ByVal cbCopy As Long)
'-------------------------------------------------
Sub test()
If TypeName(Selection) = "Range" Then
MsgBox getcol(Selection)
End If
End Sub
'-------------------------------------------------
Private Function getcol(ByRef r As Range)
Dim buf As String
Dim mem As Long
Dim sz As Long
Dim lk As Long
Dim x As Long
Application.ScreenUpdating = False
r.Item(1).Copy
OpenClipboard 0&
mem = GetClipboardData(RegisterClipboardFormatA("HTML Format"))
CloseClipboard
If mem = 0 Then Exit Function
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
With Workbooks.Add
.Sheets(1).Paste
x = Selection.Interior.ColorIndex
.Close False
End With
getcol = x
Application.ScreenUpdating = True
End Function
'-------------------------------------------------
#参考にさせて頂いたサイト
ht tp://homepage2.nifty.com/kmado/kvba.htm（E03M121）
ht tp://www.tsware.jp/study/vol1/kaibo_15.htm
|
|
n
- 11/11/4(金) 20:27 -
