Excel VBA質問箱 IV

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

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


42596 / 76732 ←次へ | 前へ→

【39201】Re:Inputboxでなくリストにするには
回答  Kein  - 06/6/19(月) 17:50 -

引用なし
パスワード
   えっと・・「氏名に対応した特定の色をセルの背景色にしたい」ということと
>「AA(内線xxx)」入力できる
これを「必要なら氏名以外の情報を入力できるようにしたい」ということと解釈し
以下のように改造してみました。
セルの入力値に"参考情報"を付加するには、コメントを使うのが一般的です。

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Stm As String, Etm As String
  Dim St As String, Unm As String, ComS As String
  Dim Sc As Integer, Ec As Integer
  Dim Rc As Long, i As Integer, Col As Integer
  Dim Flg As Boolean
  Dim C As Range
  Dim NmAry As Variant, ClAry As Variant, Num As Variant  

  If Intersect(Target, Range("E6:E65536").SpecialCells(-4174)) _
  Is Nothing Then Exit Sub
  With Target
   If .Count > 1 Then Exit Sub
   If IsEmpty(.Offset(, -1).Value) Then Exit Sub
   If Not .Validation.Value Then
     Flg = True: GoTo ELine
   End If
   Rc = .Row
   If .Offset(, -1).Value > .Value Then
     Flg = True: GoTo ELine
   End If
   Range("D6:E65536").SpecialCells(-4174).NumberFormat = "h:mm"
   Stm = .Offset(, -1).Text
   Etm = .Text
  End With
  For Each C In Range("F4:AP4")
   If C.Text = Stm Then Sc = C.Column
   If Sc > 0 Then
     If Not IsEmpty(Cells(Rc, Sc).Value) Then
      MsgBox "その時間帯は入力済みです", 48: Exit Sub
     End If
   End If
   If C.Text = Etm Then Ec = C.Column: Exit For
  Next
  If Sc = 0 Or Ec = 0 Then
   Flg = True: GoTo ELine
  End If
  NmAry = Array("AA", "BB", "CC", "DD", "EE", "FF", "GG")
  ClAry = Array(46, 47, 48, 49, 50, 51, 52)'任意のColorIndex
  St = "[氏名の番号を下記の対応表に従って入力して下さい]" & vbLf
  For i = 0 To UBound(NmAry) - 1 'NmAryの要素数が偶数なら - 1 を削除
   If i Mod 2 = 0 Then
     St = St & NmAry(i) & " = " & i + 1 & _
     " : " & NmAry(i + 1) & " = " & i + 2 & vbLf
   End If
  Next i
  Do
   Num = Application.InputBox(St, Type:=1)
   If VarType(Num) = 11 Then Exit Sub
  Loop While CInt(Num) < 1 Or CInt(Num) > 7
  Unm = NmAry(CInt(Num) - 1): Col = ClAry(CInt(Num) - 1)
ELine:
  Application.EnableEvents = False
  If Flg Then
   MsgBox "入力した値は条件に一致しません。" & _
   "クリアして終了します", 48
  Else
   With Range(Cells(Rc, Sc), Cells(Rc, Ec))
     .Value = Unm: .Interior.ColorIndex = Col
   End With
   ComS = InputBox("コメントを付加したい場合は情報を入力して下さい")
   If ComS <> "" Then Cells(Rc, Sc).AddComment ComS
  End If
  Cells(Rc, 4).Resize(, 2).ClearContents
  Application.EnableEvents = True
End Sub

* ただしコメントやセルに着けた色は、いつかクリアしたい時が来ると思います。
それは何らかのイベントマクロでやるようにすれば良いでしょう。
クリアしたいもの・場所の特定をするか、あるいはシート全体を一括処理するか、
によってもイベントの種類やコードが変わってきます。

2 hits

【38997】Inputboxでなくリストにするには にしもり 06/6/15(木) 17:55 質問
【39151】Re:Inputboxでなくリストにするには にしもり 06/6/19(月) 11:36 質問
【39165】Re:Inputboxでなくリストにするには Jaka 06/6/19(月) 14:37 発言
【39167】Re:Inputboxでなくリストにするには にしもり 06/6/19(月) 14:47 質問
【39175】Re:Inputboxでなくリストにするには Jaka 06/6/19(月) 15:50 発言
【39187】Re:Inputboxでなくリストにするには にしもり 06/6/19(月) 16:37 質問
【39191】Re:Inputboxでなくリストにするには Jaka 06/6/19(月) 16:49 発言
【39192】Re:Inputboxでなくリストにするには Kein 06/6/19(月) 16:49 回答
【39196】Re:Inputboxでなくリストにするには にしもり 06/6/19(月) 17:11 質問
【39197】Re:Inputboxでなくリストにするには にしもり 06/6/19(月) 17:14 発言
【39198】Re:Inputboxでなくリストにするには にしもり 06/6/19(月) 17:19 質問
【39201】Re:Inputboxでなくリストにするには Kein 06/6/19(月) 17:50 回答
【39202】Re:Inputboxでなくリストにするには にしもり 06/6/19(月) 18:08 質問
【39203】Re:Inputboxでなくリストにするには にしもり 06/6/19(月) 18:20 質問
【39206】Re:Inputboxでなくリストにするには Kein 06/6/19(月) 18:53 回答
【39249】Re:Inputboxでなくリストにするには にしもり 06/6/20(火) 15:05 お礼
【39251】Re:Inputboxでなくリストにするには Kein 06/6/20(火) 15:39 発言
【39264】Re:Inputboxでなくリストにするには にしもり 06/6/20(火) 18:02 お礼

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