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