| |
自分なりに考えてｺｰﾄﾞを変えさせていただきました。見当はずれなことをやっているかもしれませんがどうか笑わないでください。
いま問題となっているのは２点です。
9：00のｺﾏつまりF6が空白、9:15のｺﾏつまりG6がAAになっているとします。
例１.D6で9:00、E6で9:15が選択されたとします。
そのとき"その時間帯は入力済みです"に行かせたいわけです。
SC=6、EC=7ですからMyR = Range(Cells(6, 6), Cells(6, 7))となるから
MyR はEmptyではないとおもいます。なのに（あ）に行きません。なぜでしょうか？
例２．D6で9:00、E6で9:00が選択されたとします。
そのときF6に、たとえばAAと入るところまではいいのだが、他のすべての空白セルにAAと入ってしまいます。なぜでしょうか？
（ただ、背景色が付くのはF6だけでした。）
アドバイスよろしくお願いします。
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 Not MyR.Count = 0 Then
' 上記IF文のThen以下とElse以下を、入れかえてみました↓
If WorksheetFunction.CountA(MyR) = MyR.Count Then
MsgBox "その時間帯は入力済みです", 48
GoTo ELine2
Else
GoTo ELine
End If
Else
If IsEmpty(MyR.Value) Then
GoTo ELine
Else
' 追加しました↓ (あ）
MsgBox "その時間帯は入力済みです", 48
GoTo ELine2
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
'**挿入ここから**
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)
'**ここまで**
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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
