| |
▼Jaka さん：
まことにありがとうございます。
ですが、 Cel.ColorIndex = No でひっかかってしまいます。
NoにはColorIndexが入っているとおもうのですが・・。
どうしてでしょうか？
なお、AAとBBだけでなくCCやDD等も入力されますので勝手乍らSelectを復活させました。この点も合っているでしょうか？自信ありません。
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
Dim MyRow As Integer
Dim i As Integer
Dim j As Integer
Dim MyVal As String
Dim Cel As Range
Dim FLG2 As Boolean
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
' Do
' Unm = InputBox("氏名を入力して下さい")
' Loop While Unm = ""
Unm = InputBox("氏名を入力して下さい")
If Unm = "" Then Exit Sub
ELine:
Application.EnableEvents = False
If FLG Then
MsgBox "入力した値は条件に一致しません。" & _
"クリアして終了します", 48
Else
Range(Cells(Rc, Sc), Cells(Rc, Ec)).Value = Unm
End If
Cells(Rc, 4).Resize(, 2).ClearContents
Application.EnableEvents = True
MyRow = ActiveSheet.Range("A130").End(xlUp).Row
FLG2 = False
For Each Cel In Cells(6, 6).Resize(MyRow - 6 + 1, 36)
Select Case Cel
Case Cel.Value = "AA"
FLG2 = True
No = 46
Case Cel.Value = "BB"
FLG2 = True
No = 47
Case Cel.Value = "CC"
FLG2 = True
No = 48
End Select
If FLG2 = True Then
Cel.ColorIndex = No '←ここでひっかかる
Cel.Pattern = xlSolid
Cel.PatternColorIndex = xlAutomatic
FLG2 = False
End If
Next
End Sub
|
|
にしもり
- 06/6/19(月) 16:37 -
