| |
諸点を修正して以下のようなコードで、うまくいくと思います。
>D11に限定してるわけではないですがそこのところは自分でD31とかに直します
これはコードを書き換えなくても、入力規制を設定した範囲を自動的に取得
するように修正しました。ただし、D:E列の6行目以下に1つも入力規則を設定
したセルが無いとエラーで中断してしまいます。ご注意下さい。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Stm As String, Etm As String, Unm As String
Dim Sc As Integer, Ec As Integer, Rc As Long
Dim Flg As Boolean
Dim C As Range
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 WorksheetFunction _
.CountA(Cells(Rc, 6).Resize(, 37)) > 0 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
ElseIf C.Text = Etm Then
Ec = C.Column: Exit For
End If
Next
If Sc = 0 Or Ec = 0 Then
Flg = True: GoTo ELine
End If
Do
Unm = InputBox("氏名を入力して下さい")
Loop While Unm = ""
ELine:
Application.EnableEvents = False
If Flg Then
MsgBox "入力した値は条件に一致しません。" & _
"クリアして終了します", 48
Cells(Rc, 4).Resize(, 2).ClearContents
Else
Cells(Rc, 6).Resize(, 37).ClearContents
Range(Cells(Rc, Sc), Cells(Rc, Ec)).Value = Unm
End If
Application.EnableEvents = True
End Sub
|
|
Kein
- 06/6/8(木) 21:53 -
