Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

42148 / 76732

←次へ　｜　前へ→


	【39655】Re:「入力済み」とMSGを出すには

Kein - 06/6/28(水) 13:32 -


	引用なし

	パスワード

では、これでどうでしょーか ?

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 MyR As Range, 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
　　　Rc = .Row
　　　If Not .Validation.Value Then
　　　　 Flg = True: GoTo ELine
　　　End If
　　　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 C.Text = Etm Then Ec = C.Column: Exit For
　 Next
　 If Sc = 0 Or Ec = 0 Then
　　　Flg = True: GoTo ELine
　 End If
　 Set MyR = Range(Cells(Rc, Sc), Cells(Rc, Ec))
　 If MyR.Count = 1 Then
　　　If IsEmpty(MyR.Value) Then
　　　　 GoTo ELine
　　　Else
　　　　 GoTo ELine2
　　　End If
　 Else
　　　If WorksheetFunction.CountA(MyR) = MyR.Count Then
　　　　　MsgBox "その時間帯は入力済みです", 48
　　　　 GoTo ELine2
　　　Else
　　　　 GoTo ELine
　　　End If
　 End If
　 NmAry = Array("AA", "BB", "CC", "DD", "EE", _
　 "FF", "GG", "HH", "II", "JJ", "KK", "LL", "MM")
　 ClAry = Array(46, 47, 48, 49, 50, 51, 52, 53, 54, 3, 5, 6, 8)
　 St = "[氏名の番号を下記の対応表に従って入力して下さい]" & _
　 vbLf & "AA = 1 : "
　 For i = 1 To UBound(NmAry)
　　　If i Mod 3 = 0 Then
　　　　 St = St & NmAry(i - 2) & " = " & i - 1 & _
　　　　 " : " & NmAry(i - 1) & " = " & i & _
　　　　 " : " & NmAry(i) & " = " & i + 1 & vbLf
　　　End If
　 Next i
　 St = Left$(St, Len(St) - 1)
　 Do
　　　Num = Application.InputBox(St, Type:=1)
　　　If VarType(Num) = 11 Then GoTo ELine2
　 Loop While CInt(Num) < 1 Or CInt(Num) > 13
　 Unm = NmAry(CInt(Num) - 1): Col = ClAry(CInt(Num) - 1)
ELine:
　 Application.EnableEvents = False
　 If Flg Then
　　　MsgBox "入力した値は条件に一致しません。" & _
　　　"クリアして終了します", 48
　 Else
　　　MyR.SpecialCells(4).Value = Unm
　　　MyR.Interior.ColorIndex = Col
　　　ComS = InputBox("コメントを付加したい場合は情報を入力して下さい")
　　　If ComS <> "" Then
　　　　 Cells(Rc, Sc).AddComment ComS
　　　　 Cells(Rc, Sc).Comment.Visible = False
　　　End If
　 End If
ELine2:
　 Cells(Rc, 4).Resize(, 2).ClearContents
　 Application.EnableEvents = True
　 Set MyR = Nothing
End Sub

6 hits

▼

【39624】「入力済み」とMSGを出すには にしもり 06/6/27(火) 17:50