| 
    
     |  | えっと遅くなりましたが、そーいう仕様ならたぶんこんなコードになります。 
 Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Stm As Single, Etm As Single
 Dim Sc As Variant, Ec As Variant
 Dim Flg As Boolean
 Dim i As Long
 Dim Unm As String
 
 With Target
 If .Address <> "$E$6" Then Exit Sub
 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
 Stm = CSng(.Offset(, -1).Value)
 Etm = CSng(.Value)
 End With
 If Stm >= Etm Then
 Flg = True: GoTo ELine
 End If
 i = 6
 With Application
 Sc = .Match(Stm, Rows(4), 1)
 Ec = .Match(Etm, Rows(4), 1)
 If IsError(Sc) Or IsError(Ec) Then
 Flg = True: GoTo ELine
 End If
 Do
 If .CountA(Cells(i, 6).Resize(, 37)) = 0 Then Exit Do
 i = i + 1
 Loop
 Do
 Unm = InputBox("氏名を入力して下さい")
 Loop While Unm = ""
 ELine:
 .EnableEvents = False
 If Flg Then
 Range("D6:E6").ClearContents
 Else
 Range(Cells(i, Sc), Cells(i, Ec)).Value = Unm
 End If
 .EnableEvents = True
 End With
 End Sub
 
 
 |  |