| |
▼たけ さん：
worksheet_changeイベントが適正か否かを判断する情報がないので
呼び出したら良いようにしています。
正直まだ全体像が良く判らないので自信はないですが、叩き台くらいには
なるかと思います。
・・たけさんのBookが私の手元にあるわけではないし、どのようの目的で
どのように使うのかの情報がないので、どのタイミングで実行するかの
判断が出来ない。
'標準モジュール
Public Sub ChangeBKColor()
Const shName As String = "Sheet1" 'シート名
Dim i As Long, IMax As Long
Dim mRng As Range, rngBuf As Range
Dim ShapeName As String
Dim bkColor As Long
Worksheets(shName).Activate
Set mRng = Selection
Application.EnableEvents = False
' 指定されたセルが想定した範囲である事を確認する
'これは私にはできない(内容が不明なので情報不足。）
'以下はあくまでも例です。
' (mRngは連続しているものとする）
'
' For Each rngBuf In mRng
' If Not Intersect(rngBuf, 想定した範囲) Then Exit Sub
' Next
'判定
IMax = mRng.Count
For i = 1 To IMax
Select Case mRng.Item(i).Value
Case 1
ShapeName = "pp001"
bkColor = 1
Case 2
ShapeName = "pp002"
bkColor = 2
Case 3
ShapeName = "pp003"
bkColor = 3
Case 4
ShapeName = "pp004"
bkColor = 4
Case 5
ShapeName = "pp005"
bkColor = 5
Case 6
ShapeName = "pp006"
bkColor = 6
Case 7
ShapeName = "pp007"
bkColor = 7
Case 8
ShapeName = "pp008"
bkColor = 8
Case 9
ShapeName = "pp009"
bkColor = 9
Case Else
ShapeName = ""
bkColor = -1
End Select
'色付け
If ShapeName <> "" And bkColor <> -1 Then
Sheets("反映シート").Select
ActiveSheet.Shapes(ShapeName).Select
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 10
End If
Next
Application.EnableEvents = True
Set mRng = Nothing
End Sub
|
|
neptune
- 09/5/13(水) 22:00 -
