Excel VBA質問箱 IV

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

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


4424 / 13644 ツリー ←次へ | 前へ→

【56741】入力規則からの書式設定について りんご 08/7/2(水) 21:59 質問[未読]
【56743】Re:入力規則からの書式設定について n 08/7/2(水) 22:54 発言[未読]

【56741】入力規則からの書式設定について
質問  りんご  - 08/7/2(水) 21:59 -

引用なし
パスワード
   はじめまして。
皆さんの知恵とアイディアをお借りしたく、質問させて頂きました。

仕事でエクセルシートを用いてDBのようなものを作っているのですが
どうも巧くいかない点があります。

”ステータス”という列の内容から
その行全てに別々の書式を設定したいのです。
ステータス列の内容は全て「入力規則⇒リスト」なっています。


管理No.  内容   ステータス
1     ・・・    完了
2     ・・・   返信待ち
3     ・・・   対応中


といった具合です。
これを実現するコードとして思いついたのが以下になります。


Private Sub Worksheet_Change(ByVal Target As Range)

  Set fc = Worksheets(1).Range("D4:AG4").Find(What:="ステータス")
  If fc Is Nothing Or Target.Column <> fc.Column Then Exit Sub

  Select Case Target.Value
    Case "対応中"
      // 書式を出力する範囲 //
    Case "返事待ち"
      // 書式を出力する範囲 //
    Case "完了"
      // 書式を出力する範囲 //
     ・
     ・
     ・
    Case Else
      // 書式を元に戻す範囲 //
  End Select

End Sub


しかし、上記のコードの場合、
複数のセルを選択し、deleteキーを押すとエラーが発生してしまいます。

この「複数セルを選択して削除」した場合も正常に動作する
方法が分かりません。

「条件付き書式」で作成することが可能なことは分かっていますが、
ステータスの内容が4項目以上なので、使用しないことにしました。


上記の現象を回避する方法、または根本的に違う方法からできるよ!
という方がいましたら、ご教示願えますでしょうか?


要点をまとめますと
・ステータスの内容から指定範囲に書式を出力する。
・ステータス欄は入力規則のリスト化されている。
・ボタン操作からではなく、あくまでも「リストから選択したら書式を出力」としたい。

以上、宜しくお願い致します。

【56743】Re:入力規則からの書式設定について
発言  n  - 08/7/2(水) 22:54 -

引用なし
パスワード
   Intersectメソッドで共有セル範囲を得、Loop処理するとよいです。

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim fc As Range
  Dim rs As Range
  Dim r As Range

  Set fc = Range("D4:AG4").Find(What:="ステータス")
  If fc Is Nothing Then Exit Sub
  Set rs = Intersect(Target, Range(fc.Offset(1), Cells(Rows.Count, fc.Column)))
  If Not rs Is Nothing Then
    For Each r In rs
      Select Case r.Value
        Case "対応中"
          '// 書式を出力する範囲 //
        Case "返事待ち"
          '// 書式を出力する範囲 //
        Case "完了"
          '// 書式を出力する範囲 //
          '・
          '・
          '・
        Case Else
          '// 書式を元に戻す範囲 //
      End Select
    Next
  End If

  Set rs = Nothing
  Set fc = Nothing
End Sub

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