Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


20643 / 76732 ←次へ | 前へ→

【61502】Re:任意のセルに入力後、オートシェイプに反映させたい
回答  neptune  - 09/5/13(水) 22:00 -

引用なし
パスワード
   ▼たけ さん:

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

1 hits

【61472】任意のセルに入力後、オートシェイプに反映させたい たけ 09/5/12(火) 13:11 質問
【61473】Re:任意のセルに入力後、オートシェイプに... neptune 09/5/12(火) 13:51 発言
【61474】Re:任意のセルに入力後、オートシェイプに... たけ 09/5/12(火) 14:03 発言
【61475】Re:任意のセルに入力後、オートシェイプに... neptune 09/5/12(火) 16:34 回答
【61477】Re:任意のセルに入力後、オートシェイプに... たけ 09/5/12(火) 21:27 発言
【61479】Re:任意のセルに入力後、オートシェイプに... neptune 09/5/12(火) 23:02 回答
【61488】Re:任意のセルに入力後、オートシェイプに... neptune 09/5/13(水) 12:18 発言
【61492】Re:任意のセルに入力後、オートシェイプに... たけ 09/5/13(水) 14:46 発言
【61502】Re:任意のセルに入力後、オートシェイプに... neptune 09/5/13(水) 22:00 回答
【61512】Re:任意のセルに入力後、オートシェイプに... たけ 09/5/14(木) 9:59 発言
【61522】Re:任意のセルに入力後、オートシェイプに... neptune 09/5/14(木) 13:07 発言
【61524】Re:任意のセルに入力後、オートシェイプに... たけ 09/5/14(木) 13:37 発言
【61528】Re:任意のセルに入力後、オートシェイプに... neptune 09/5/14(木) 16:35 発言
【61539】Re:任意のセルに入力後、オートシェイプに... たけ 09/5/15(金) 13:19 発言
【61543】Re:任意のセルに入力後、オートシェイプに... neptune 09/5/15(金) 16:52 発言
【61564】Re:任意のセルに入力後、オートシェイプに... たけ 09/5/18(月) 21:15 お礼

20643 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free