Excel VBA質問箱 IV

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

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


7335 / 13644 ツリー ←次へ | 前へ→

【39624】「入力済み」とMSGを出すには にしもり 06/6/27(火) 17:50 質問[未読]
【39632】Re:「入力済み」とMSGを出すには Kein 06/6/27(火) 23:16 回答[未読]
【39641】Re:「入力済み」とMSGを出すには にしもり 06/6/28(水) 4:25 質問[未読]
【39644】Re:「入力済み」とMSGを出すには にしもり 06/6/28(水) 9:00 質問[未読]
【39651】Re:「入力済み」とMSGを出すには にしもり 06/6/28(水) 10:23 質問[未読]
【39655】Re:「入力済み」とMSGを出すには Kein 06/6/28(水) 13:32 回答[未読]
【39660】Re:「入力済み」とMSGを出すには にしもり 06/6/28(水) 14:18 質問[未読]
【39703】Re:「入力済み」とMSGを出すには にしもり 06/6/29(木) 12:12 質問[未読]
【39707】Re:「入力済み」とMSGを出すには にしもり 06/6/29(木) 13:29 質問[未読]
【39715】Re:「入力済み」とMSGを出すには にしもり 06/6/29(木) 15:30 質問[未読]
【39719】Re:「入力済み」とMSGを出すには にしもり 06/6/29(木) 18:20 質問[未読]
【39732】Re:「入力済み」とMSGを出すには Kein 06/6/29(木) 23:41 発言[未読]
【39733】Re:「入力済み」とMSGを出すには Kein 06/6/29(木) 23:42 発言[未読]
【39736】Re:「入力済み」とMSGを出すには にしもり 06/6/30(金) 9:09 質問[未読]
【39740】Re:「入力済み」とMSGを出すには にしもり 06/6/30(金) 9:36 質問[未読]
【39744】Re:「入力済み」とMSGを出すには にしもり 06/6/30(金) 10:32 回答[未読]

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

引用なし
パスワード
   【38997】の関連で教えてください。
Keinさんにいろいろ教えていただきました。
9:15のコマと 9:30のコマに両方にデータが入っているとします。
いま9:00のコマと9:15のコマに予約しようとすると「その時間帯は入力済みです」とでるはず(と思っていたの)ですが、入力できてしまいます。
上のような条件のとき「その時間帯は入力済みです」を出すにはどうすればよいですか? 勿論自分でも考えますがアドバイスよろしくお願いします。

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 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
   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
  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 Exit Sub
  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
   With Range(Cells(Rc, Sc), Cells(Rc, Ec))
     .Value = Unm: .Interior.ColorIndex = Col
   End With
   ComS = InputBox("コメントを付加したい場合は情報を入力して下さい")
   If ComS <> "" Then
     Cells(Rc, Sc).AddComment ComS
     Cells(Rc, Sc).Comment.Visible = False
   End If
  End If
  Cells(Rc, 4).Resize(, 2).ClearContents
  Application.EnableEvents = True
End Sub

【39632】Re:「入力済み」とMSGを出すには
回答  Kein  - 06/6/27(火) 23:16 -

引用なし
パスワード
   あー・・確かにそのコードではそうなりますね・・。すいません、ループの部分を

>  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


  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
  If WorksheetFuction _
  .CountA(Range(Cells(Rc, Sc), Cells(Rc, Ec))) > 0 Then
   MsgBox "その時間帯は入力済みです", 48: Exit Sub
  End If

と、変更してみて下さい。

【39641】Re:「入力済み」とMSGを出すには
質問  にしもり  - 06/6/28(水) 4:25 -

引用なし
パスワード
   ▼Kein さん:
再々すみません。
ループの箇所の改定が必要だとわたくしにもわかりましたが
正直歯が立ちませんでした。
早速ご回答通りに行なってみたのですが、
If WorksheetFuction _
  .CountA(Range(Cells(Rc, Sc), Cells(Rc, Ec))) > 0 Then
でエラー(黄色)になってしまします。
恐れ入りますがもう一度見ていただけませんでしょうか。

【39644】Re:「入力済み」とMSGを出すには
質問  にしもり  - 06/6/28(水) 9:00 -

引用なし
パスワード
   ▼kein様
さらにもう一点ですが、
Stm9:00、Etm9:00つまり9:00のコマだけに入力しようとすると
9:00のコマだけに名が入るはずなのに、その入力は条件に一致しません、に飛んでしまいます。
自分でも考えていますが是非アドバイスお願いします。
申し訳ありません。

【39651】Re:「入力済み」とMSGを出すには
質問  にしもり  - 06/6/28(水) 10:23 -

引用なし
パスワード
   ▼Kein さん:
【39641】はWorksheetFunctionのnが抜けていたようでございます。
【39644】はまだ自力で解決できておりません。

【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

【39660】Re:「入力済み」とMSGを出すには
質問  にしもり  - 06/6/28(水) 14:18 -

引用なし
パスワード
   ▼Kein さん:
新しくELine2を追加するのですね。
自力でなんとかできないかとやってみましたが、わたくしには構造全体を見て修正するという発想がありませんでした。

ところで申し訳ないのですが、
9:15のコマと 9:30のコマに両方にデータが入っているとき9:00のコマと9:15のコマに入力しようとすると"その時間帯は入力済みです"と出ずに入力できてしまい、"コメントを付加したい場合は情報を入力して下さい"に飛んでしまいます。
また、Stmを9:00、Etmを9:00にしたときは、(入力できること自体はいいのですが)、いきなり"コメントを付加したい場合は情報を入力して下さい"に飛んでしまいます。
よくよくやってみると、いずれも名前をきいてくることなく入力できてしまい"コメントを付加したい場合は情報を入力して下さい"に飛んでしまうようです。

そこで、
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
'**挿入ここから**
   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
'**ここまで**
   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

という風にかえてみました。
しかし、結果は同じでした。
どうすればよろしいいでしょうか。
アドバイスよろしくお願いします。

【39703】Re:「入力済み」とMSGを出すには
質問  にしもり  - 06/6/29(木) 12:12 -

引用なし
パスワード
   自分なりに考えてコードを変えさせていただきました。見当はずれなことをやっているかもしれませんがどうか笑わないでください。
いま問題となっているのは2点です。

9:00のコマつまりF6が空白、9:15のコマつまりG6がAAになっているとします。

例1.D6で9:00、E6で9:15が選択されたとします。
そのとき"その時間帯は入力済みです"に行かせたいわけです。
SC=6、EC=7ですからMyR = Range(Cells(6, 6), Cells(6, 7))となるから
MyR はEmptyではないとおもいます。なのに(あ)に行きません。なぜでしょうか?

例2.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



【39707】Re:「入力済み」とMSGを出すには
質問  にしもり  - 06/6/29(木) 13:29 -

引用なし
パスワード
   問題は2点と申しましたが下のケースもうまくいきませんでした。

9:00のコマつまりF6が空白、9:15のコマつまりG6がAA、9:30のコマつまりH6が空白になっているとします。

例3.D6で9:15、E6で9:30が選択されたとします。
そのときも、"その時間帯は入力済みです"に行かせたいわけです。
しかし、そうならず上書きしてしまします。
【39703】のコードのどこを変えればよろしいでしょうか?
あと少しでできそうな気がするのですが甘いでしょうか。。

【39715】Re:「入力済み」とMSGを出すには
質問  にしもり  - 06/6/29(木) 15:30 -

引用なし
パスワード
   【39703】の例1と【39707】の例3をなんとか自力で解決しました。
しかし、【39703】で申した例2は依然解決しておりません。
アドバイスありましたらよろしくお願いします。

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文を変えてみました↓
   If WorksheetFunction.CountA(MyR) >= 1 Then
   'CountA(MyR) が1以上、つまりそこが入力済であったなら。
       MsgBox "その時間帯は入力済みです", 48
       GoTo ELine2
'   Else
'       MsgBox "その時間帯は入力済みです", 48
'       GoTo ELine2
''     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

【39719】Re:「入力済み」とMSGを出すには
質問  にしもり  - 06/6/29(木) 18:20 -

引用なし
パスワード
   >しかし、【39703】で申した例2は依然解決しておりません。
 MyR.SpecialCells(4).Value = Unmに問題があるのかなと思っています。
ある本によるとSpecialCellsメソッドの引数valueに定数xlLogicalの値4を設定すると論理値になるというようなことが書いてありました。
が、なんのことかさっぱりわかりません。SpecialCellsメソッドの正しい使い方を教えていただけませんでしょうか?

【39732】Re:「入力済み」とMSGを出すには
発言  Kein  - 06/6/29(木) 23:41 -

引用なし
パスワード
   あー・・すいません。昨日よりちょっと体調を崩してダウンしてますので、回答は
もうしばらくお待ちください。なお、SpecialCellsメソッドの引数については
以下のように数値と文字定数かぜ対応しています。

xlCellTypeConstant = 2
xlCellTypeFormulas = 3
xlCellTypeBlanks = 4
xlCellTypeLastCell = 11
xlCellTypeVisible = 12
xlCellTypeComments = -4144
xlCellTypeAllFormatConditions = -4172
xlCellTypeSameFormatConditions = -4173
xlCellTypeAllValidation = -4174
xlCellTypeSameValidation = -4175
[第二引数]
xlNumbers = 1
xlTextValues = 2
xlLogical = 4
xlErrors = 16

【39733】Re:「入力済み」とMSGを出すには
発言  Kein  - 06/6/29(木) 23:42 -

引用なし
パスワード
   >文字定数かぜ

文字定数が

【39736】Re:「入力済み」とMSGを出すには
質問  にしもり  - 06/6/30(金) 9:09 -

引用なし
パスワード
   ▼Kein さん:
ご体調不十分とのこと、無理をなさらないでください。
私の買った本にはSpecialCellsメソッドについての言及こそありましたが
数値と文字定数が対応しているとはどこにも書いてありませんでした。
とても面白いですね、こういうことを理解し駆使できたら。
単純労働がパソコンにとって代わられ、複雑なことができる人とできない人の格差が広がっている今、こういう高度なことを教える社会の仕組みができそれが一般化すれば格差も少しは是正されるのでは、と思います。
話が逸れましたが、ブランクセルが「AA」で埋まってしまったのはxlCellTypeBlanks = 4を指定していたからでしょうか?
ほかの引数にしてやってみます。

【39740】Re:「入力済み」とMSGを出すには
質問  にしもり  - 06/6/30(金) 9:36 -

引用なし
パスワード
   SpecialCellsの引数を変えただけではだめでした。
引き続き修正すべき箇所はどこか検討いたします。

ところで各引数の意味は下記の理解でよろしいでしょうか?
参考のため教えていただけると幸いです。
-4172 と-4173だけは意味がわかりませんでした。
 
xlCellTypeConstant = 2 文字が入っているところ
xlCellTypeFormulas = 3 式が入っているところ
xlCellTypeBlanks = 4 ブランクのところ
xlCellTypeLastCell = 11 最右下端
xlCellTypeVisible = 12 すべて
xlCellTypeComments = -4144 コメントのはいっているところ
xlCellTypeAllFormatConditions = -4172 ←わかりませんでした。
xlCellTypeSameFormatConditions = -4173 ←わかりませんでした。
xlCellTypeAllValidation = -4174 入力規制のかかっているところ
xlCellTypeSameValidation = -4175 同じ入力規制のかかっているところ

【39744】Re:「入力済み」とMSGを出すには
回答  にしもり  - 06/6/30(金) 10:32 -

引用なし
パスワード
   Kein様
どうやら自力でできたようでございます。
MyR.SpecialCells(4).Value = Unmを MyR.Value = Unmに変えればよいことに気づきました。すべてのケースをテストしてみて、どうやらokのようです。
しかし、エキスパートの方から見るとつぎはぎだらけのように見えるのではないでしょうか。もし無駄なコードがありましたらどうかご指摘ください。


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 Not MyR.Count = 0 Then
   If WorksheetFunction.CountA(MyR) >= 1 Then
     MsgBox "その時間帯は入力済みです", 48
     GoTo ELine2
   End If
  Else
   If IsEmpty(MyR.Value) Then
     GoTo ELine
   End If
  End If
 
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.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

7335 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free