EXCEL VBA 指定した数字ごとに表示

質問

http://okwave.jp/qa/q8818467.html

上記をこちらで教えていただき、入力してENTERすると思ったとおりの表示がされるのですが、別のセルからコピーするとうまくいきません。

原因はなんでしょうか？

よろしくお願い致します。

回答No.1

keithin · ベストアンサー

正しくないデータが記入されているようなので、少し手直しする事にします

手順：
シート名タブを右クリック、コードの表示を選ぶ
現れたシートに記載されている内容を全て消去し、改めて下記をコピー貼り付ける

option base 1
private sub Worksheet_Change(byval Target as excel.range)
　dim h as range
　dim a as variant
　a = application.transpose(range("A1:A3"))　’Ａ１からＡ３に時刻を記入
　on error resume next

　for each h in application.intersect(target, range("D:D"))
　　if cells(h.row, "F") <> "○" then
　　if 1=< h.value and h.value <= 3 then　　’１から３
　　if time >= a(h.value) then
　　　cells(h.row, "F") = a(h.value)
　　end if
　　end if
　　end if
　next
end sub

回答No.2

WindFaller

以下は、
http://okwave.jp/qa/q8764434.html
の質問を元にしました。

何か、同じような質問と、同じようなパターンのコードが、数ヶ月に渡って続いているようです。
もう少し考えて、丁寧に質問したほうがよいと思いますね。ポイントを押さえたほうがよいです。エラー処理には、ユーザーの任意の値ですから、こちら側では、想像しにくいものがあります。

>a = array("cell(1,1)", "cell(1,2)", "cell(1,3)"）みたいなイメージです
これは、よく分からないですね。セルを参照するのなら、配列など必要はないはずです。

'//単一セルを使う場合
Private Sub Worksheet_Change(ByVal Target As Range)
　With Target
　If .Column <> 4 Then Exit Sub　'D列
　If .Count > 1 Then Exit Sub　'複数のセルをまたいだ場合は、不可
　If .Value = "" Then .Offset(, 2).Clear: Exit Sub 'D列の数字を削除すれば、F列も消える
　If .Value < 1 Or .Value > 3 Then Exit Sub　'入力は1から3まで
　If .Offset(, 2).Value = "○" Then Exit Sub
　If TimeValue(Cells(.Value, 1).Text) > Time Then Exit Sub
　Application.EnableEvents = False　'再帰を防ぐ
　　.Offset(, 2).Value = Cells(.Value, 1).Text　'2列先にコピー・ペーストする
　Application.EnableEvents = True
　End With
End Sub
'//

>別のセルからコピーするとうまくいきません。
どこからどこへ、何をコピーしたのか分からないので、私には、よく意味が理解できません。
もしかしたら、D列に入力をコピーで貼付けしたという意味なら、上記のコードが大幅に変わってきます。

'//複数のセルを一度に使う場合

Private Sub Worksheet_Change(ByVal Target As Range)
　Dim c As Range
　If Target.Column <> 4 Then Exit Sub 'D列
　For Each c In Target
　　If c.Value <> "" Then 'セルを消したり、空だった場合
　　　If c.Value >= 1 And c.Value <= 3 Then '入力は1から3まで
　　　　If c.Offset(, 2).Value <> "○" Then
　　　　　If TimeValue(Cells(c.Value, 1).Text) <= Time Then
　　　　　　Application.EnableEvents = False '再帰を防ぐ
　　　　　　c.Offset(, 2).Value = Cells(c.Value, 1).Text
　　　　　　Application.EnableEvents = True
　　　　　End If
　　　　End If
　　　End If
　　Else
　　　c.Offset(, 2).Clear '2列先のセル内容を消去
　　End If
　Next c
End Sub
'//