Excel VBA質問箱 IV

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

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


7426 / 13645 ツリー ←次へ | 前へ→

【38997】Inputboxでなくリストにするには にしもり 06/6/15(木) 17:55 質問[未読]
【39151】Re:Inputboxでなくリストにするには にしもり 06/6/19(月) 11:36 質問[未読]
【39165】Re:Inputboxでなくリストにするには Jaka 06/6/19(月) 14:37 発言[未読]
【39167】Re:Inputboxでなくリストにするには にしもり 06/6/19(月) 14:47 質問[未読]
【39175】Re:Inputboxでなくリストにするには Jaka 06/6/19(月) 15:50 発言[未読]
【39187】Re:Inputboxでなくリストにするには にしもり 06/6/19(月) 16:37 質問[未読]
【39191】Re:Inputboxでなくリストにするには Jaka 06/6/19(月) 16:49 発言[未読]
【39192】Re:Inputboxでなくリストにするには Kein 06/6/19(月) 16:49 回答[未読]
【39196】Re:Inputboxでなくリストにするには にしもり 06/6/19(月) 17:11 質問[未読]
【39197】Re:Inputboxでなくリストにするには にしもり 06/6/19(月) 17:14 発言[未読]
【39198】Re:Inputboxでなくリストにするには にしもり 06/6/19(月) 17:19 質問[未読]
【39201】Re:Inputboxでなくリストにするには Kein 06/6/19(月) 17:50 回答[未読]
【39202】Re:Inputboxでなくリストにするには にしもり 06/6/19(月) 18:08 質問[未読]
【39203】Re:Inputboxでなくリストにするには にしもり 06/6/19(月) 18:20 質問[未読]
【39206】Re:Inputboxでなくリストにするには Kein 06/6/19(月) 18:53 回答[未読]
【39249】Re:Inputboxでなくリストにするには にしもり 06/6/20(火) 15:05 お礼[未読]
【39251】Re:Inputboxでなくリストにするには Kein 06/6/20(火) 15:39 発言[未読]
【39264】Re:Inputboxでなくリストにするには にしもり 06/6/20(火) 18:02 お礼[未読]

【38997】Inputboxでなくリストにするには
質問  にしもり  - 06/6/15(木) 17:55 -

引用なし
パスワード
   こんにちは。
【38613】の関連です。
一度完結しておりますので新たに質問いたします。すみません。m(_ _;)m
Keinさんには、氏名の入力をInputboxでするようにつくっていただきました。
これを、プルダウンで選ぶ形式に変えるにはどうしたらよろしいでしょうか。
といいますのは、F6から右あるいはF6から下のセルを出勤者別に色分けしたいとおもうのです。人がそれほど多くない(例えば AA ,BB,CC,DD,EE,FF,GGさんの7名とします )ので、色分け自体は条件付書式で条件を追加すればいいと思っています。しかしInputboxでは、やたらめったらな字が入れられるとおもうので、AA ,BB,CC,DD,EE,FF,GGからプルダウンで選ばせたいのです。
どうすればよろしいでしょうか?

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

  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
End Sub

【39151】Re:Inputboxでなくリストにするには
質問  にしもり  - 06/6/19(月) 11:36 -

引用なし
パスワード
   自己レスです。
自分で調べましたところ、inputBoxをリストのようにする方法は無いようでした。
また、そもそも条件つき書式は条件が3つまでしか追加できないことがわかりました。そこで自力で以下のコードを追加しました。
しかし、エラーにこそならないものの、うんともすんとも言いません。
すみません、基本ができていません。
どこが悪いか教えてください。

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
 
  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

'*********追加ここから*******

  MyRow ActiveSheet.Range("A130").End(xlUp).Row
    For j = 6 To MyRow
      For i = 0 To 36
      MyVal = ActiveSheet.Cells(6, j).Offset(i, 0)
     
      Select Case ActiveCell 
      
        Case MyVal = "AA"
        ActiveCell.Select
        With Selection.Interior
          .ColorIndex = 46
          .Pattern = xlSolid
          .PatternColorIndex = xlAutomatic
         End With
         
         Case MyVal = "BB"
        ActiveCell.Select
        With Selection.Interior
          .ColorIndex = 47
          .Pattern = xlSolid
          .PatternColorIndex = xlAutomatic
        End With
      
      Next i
    Next j
'*********ここまで**********

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
End Sub

【39165】Re:Inputboxでなくリストにするには
発言  Jaka  - 06/6/19(月) 14:37 -

引用なし
パスワード
   >'*********追加ここから*******
>
>  MyRow ActiveSheet.Range("A130").End(xlUp).Row
>    For j = 6 To MyRow
>      For i = 0 To 36
>      MyVal = ActiveSheet.Cells(6, j).Offset(i, 0)
>     
>      Select Case ActiveCell
              ↑
    このActiveCellってのが、よく解らないんですが...。
    使い方が間違っているような気もするし、
    セルに何か書き込んだ場合、アクティブセルと
    書き込んだセル(Targetセル?)の位置は違うと思いますが。         
>      
>        Case MyVal = "AA"
>        ActiveCell.Select
>        With Selection.Interior
>          .ColorIndex = 46
>          .Pattern = xlSolid
>          .PatternColorIndex = xlAutomatic
>         End With
>         
>         Case MyVal = "BB"
>        ActiveCell.Select
>        With Selection.Interior
>          .ColorIndex = 47
>          .Pattern = xlSolid
>          .PatternColorIndex = xlAutomatic
>        End With
>      
>      Next i
>    Next j
>'*********ここまで**********

【39167】Re:Inputboxでなくリストにするには
質問  にしもり  - 06/6/19(月) 14:47 -

引用なし
パスワード
   ▼Jaka さん:
>    セルに何か書き込んだ場合、アクティブセルと
>    書き込んだセル(Targetセル?)の位置は違うと思いますが。  
あ、そうですね。
自分のやりたいことを整理しました。
わたしは、何か書き込んだそのセルで発生したイベントがすべて終わったそのあとで、あらためてひとつひとつのセルに条件に応じて色付けをしようとしています。(それがまっとうなやり方かどうかは自信ありません。)
下は130行まで、右はAP列までひとつひとつ値を見、それがAAなら橙色にする・・という具合です。
自力で考えますが、よきアドバイスがありましたら是非お願いします。
    

【39175】Re:Inputboxでなくリストにするには
発言  Jaka  - 06/6/19(月) 15:50 -

引用なし
パスワード
   ▼にしもり さん:
>わたしは、何か書き込んだそのセルで発生したイベントがすべて終わったそのあとで、あらためてひとつひとつのセルに条件に応じて色付けをしようとしています。(それがまっとうなやり方かどうかは自信ありません。)
発生したイベントが全て終わった後って、どんな順番やタイミングで処理されているのかわからないので何ともいえませんが、ループはこんな感じで良いんじゃないかと

Dim FLG As Boolean, Cel As Range
MyRow = ActiveSheet.Range("A130").End(xlUp).Row
FLG = False
For Each Cel In Cells(6, 6).Resize(MyRow - 6 + 1, 36)
  If Cel.Value = "AA" Then
    FLG = True
    No = 46
  ElseIf Cel.Value = "BB" Then
    FLG = True
    No = 47
  End If
  If FLG = True Then
    Cel.ColorIndex = No
    Cel.Pattern = xlSolid
    Cel.PatternColorIndex = xlAutomatic
    FLG = False
  End If
Next

【39187】Re:Inputboxでなくリストにするには
質問  にしもり  - 06/6/19(月) 16:37 -

引用なし
パスワード
   ▼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

【39191】Re:Inputboxでなくリストにするには
発言  Jaka  - 06/6/19(月) 16:49 -

引用なし
パスワード
   忘れてました。

    With Cel.Interior
     .ColorIndex = No
      .Pattern = xlSolid
      .PatternColorIndex = xlAutomatic
    End with

【39192】Re:Inputboxでなくリストにするには
回答  Kein  - 06/6/19(月) 16:49 -

引用なし
パスワード
   未テストですが、こんな感じでどうでしょーか ?
プルダウンするコントロールを配置する方法もありますが、より簡単に済ませるため
InputBoxに番号を入れる方法にしています。
ただし、名前が多くなると表示し切れなくなるので、7名ぐらいにしておいて下さい。

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Stm As String, Etm As String
  Dim St As String, Unm As String
  Dim Sc As Integer, Ec As Integer
  Dim Rc As Long, i As Integer
  Dim Flg As Boolean
  Dim C As Range
  Dim NmAry 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")
  St = "[氏名の番号を下記の対応表に従って入力して下さい]" & vbLf
  For i = 0 To UBound(NmAry) - 1 'NmAryの要素数が偶数なら - 1 を削除
   If i Mod 2 = 0 Then
     St = St & NmAry(i) & " = " & i + 1 & _
     " : " & NmAry(i + 1) & " = " & i + 2 & vbLf
   End If
  Next i
  Do
   Num = Application.InputBox(St, Type:=1)
   If VarType(Num) = 11 Then Exit Sub
  Loop While CInt(Num) < 1 Or CInt(Num) > 7
  Unm = NmAry(CInt(Num) - 1)
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
End Sub

【39196】Re:Inputboxでなくリストにするには
質問  にしもり  - 06/6/19(月) 17:11 -

引用なし
パスワード
   ▼Kein さん:
まことにありがとうございます。
InputBoxを事実上リストボックスのように使おうというご発想だと思います。
わたくしの最初の意に沿っていただいたのだと存じます。
厳密に色分けするには「AA」や「BB」という決まった値を入力させねばいけないわけですが、わたくしは、リストボックスができないとわかった時点で柔軟に考えました。たとえば、「AA」と入れない人も確かにいるが、「AA(内線xxx)」入力できるなど、自由度が高まったのだからそれはそれでいいのではないか、と。
そいういう意味でKeinさん作成のInputBoxを引きつづきつかわせていただき、
たとえば「AA」と入ってきたら橙色にするが、「AA(内線xxx)」と入ってきたらセルの色はそのままにしよう、と思っています。
わがままでまことに申し訳ありません。

ところで【39817】の質問はいまだ解決できておりません。よきアドバイスを是非お願いします。

【39197】Re:Inputboxでなくリストにするには
発言  にしもり  - 06/6/19(月) 17:14 -

引用なし
パスワード
   >ところで【39817】の質問はいまだ解決できておりません。よきアドバイスを是非お願いします。
ごめんなさい。Jakaさんから16:49にアドバイスいただいてました。やってみます。

【39198】Re:Inputboxでなくリストにするには
質問  にしもり  - 06/6/19(月) 17:19 -

引用なし
パスワード
   ▼Jakaさん
あれ- AAとか字の入ったセルを橙色にしたいのに、空白セルが橙色になっちゃいました。(それはそれで美しいのだけれども!)
何かが逆になっている模様です。

【39201】Re:Inputboxでなくリストにするには
回答  Kein  - 06/6/19(月) 17:50 -

引用なし
パスワード
   えっと・・「氏名に対応した特定の色をセルの背景色にしたい」ということと
>「AA(内線xxx)」入力できる
これを「必要なら氏名以外の情報を入力できるようにしたい」ということと解釈し
以下のように改造してみました。
セルの入力値に"参考情報"を付加するには、コメントを使うのが一般的です。

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")
  ClAry = Array(46, 47, 48, 49, 50, 51, 52)'任意のColorIndex
  St = "[氏名の番号を下記の対応表に従って入力して下さい]" & vbLf
  For i = 0 To UBound(NmAry) - 1 'NmAryの要素数が偶数なら - 1 を削除
   If i Mod 2 = 0 Then
     St = St & NmAry(i) & " = " & i + 1 & _
     " : " & NmAry(i + 1) & " = " & i + 2 & vbLf
   End If
  Next i
  Do
   Num = Application.InputBox(St, Type:=1)
   If VarType(Num) = 11 Then Exit Sub
  Loop While CInt(Num) < 1 Or CInt(Num) > 7
  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
  End If
  Cells(Rc, 4).Resize(, 2).ClearContents
  Application.EnableEvents = True
End Sub

* ただしコメントやセルに着けた色は、いつかクリアしたい時が来ると思います。
それは何らかのイベントマクロでやるようにすれば良いでしょう。
クリアしたいもの・場所の特定をするか、あるいはシート全体を一括処理するか、
によってもイベントの種類やコードが変わってきます。

【39202】Re:Inputboxでなくリストにするには
質問  にしもり  - 06/6/19(月) 18:08 -

引用なし
パスワード
   ▼Kein さん:
ありがとうございます。
凄いとしか言いようがありません。
質問です。コメントを非表示にするには、おそらくAddCommentのあとに何らかの属性を書くのでしょうけれども、それを教えていただけませんか。
あと、InputBoxに表示する名前は7つくらい迄とのことでしたけど、もっと要る場合に方法はありませんでしょうか?ちなみに13個です。InputBoxの右寄りの空白を生かせないでものしょうか。

【39203】Re:Inputboxでなくリストにするには
質問  にしもり  - 06/6/19(月) 18:20 -

引用なし
パスワード
   ▼Kein さん:

>質問です。コメントを非表示にするには、おそらくAddCommentのあとに何らかの属性を書くのでしょうけれども、それを教えていただけませんか。
あ、個別のPCの表示の設定の問題だったようです。すみません。

「13個表示したい件」のほうは可能でしょうか?

【39206】Re:Inputboxでなくリストにするには
回答  Kein  - 06/6/19(月) 18:53 -

引用なし
パスワード
   >コメントを非表示
>ちなみに13個
なら、こんな感じでどうでしょーか ?

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

【39249】Re:Inputboxでなくリストにするには
お礼  にしもり  - 06/6/20(火) 15:05 -

引用なし
パスワード
   ▼Kein さん:
おかげさまで希望どおりになりました。
本当にありがとうございます。
なんと申し上げていいかわかりません。
しかし自分では書けません。
このコードを自分なりに追って理解に努めようと思います。
それがいまの自分にできるせめてものことがらです。
本当にありがとうございました。
アドバイスをいただいたjaka様にも御礼申し上げます。

【39251】Re:Inputboxでなくリストにするには
発言  Kein  - 06/6/20(火) 15:39 -

引用なし
パスワード
   当面の目的は達したようですが、それだけで何度も使いまわしが
出来るわけではありません。くどいようですが
>* ただしコメントやセルに着けた色は、いつかクリアしたい時が来ると思います。
>それは何らかのイベントマクロでやるようにすれば良いでしょう。
>クリアしたいもの・場所の特定をするか、あるいはシート全体を一括処理するか、
>によってもイベントの種類やコードが変わってきます。
を、検討する必要が出てくると思いますから。

【39264】Re:Inputboxでなくリストにするには
お礼  にしもり  - 06/6/20(火) 18:02 -

引用なし
パスワード
   ▼Kein さん:
>当面の目的は達したようですが、それだけで何度も使いまわしが
>出来るわけではありません。

承知いたしました。当面は「編集」「クリア」「コメント」で消そうとおもいます。マクロが必要な局面になったときのために、研鑽したいとおもっております。

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