エクセル VBA の質問です。

A2～A20までのセルに文字を入力した段階で、それぞれB2～B20に入力日時を入れるVBAを以下のように組んでいます。

しかし、同様の条件を同一シートのE2～E20・F2～F20にも入力・自動表示できるようにしなければならなくなり、困っています。

どのように記述を変えればよいのか、教えていただけたらと思います。

宜しく御願いいたします。


Sub Worksheet_change(ByVal Target As Range)
Dim Rng As Range
Dim c As Range

Set Rng = Range("A2:A20")

If Intersect(Target,Rng) Is Nothing Then Exit Sub

For Each c In Intersect(Target,Rng)
If Not IsEmpty(c) Then
c.Offset(, 1).Value = Now
Else
c.Offset(, 1).ClearContents
End If
Next
Rng.Offset(, 1).EntireColumn.AutoFit
End Sub

申し訳ありませんが、何卒、宜しく御願いいたします。

No.3 ベストアンサー 回答者： imogasi 回答日時： 2011/04/15 21:13

Private Sub Worksheet_change(ByVal Target As Range)

Application.EnableEvents = False
Dim Rng As Range
Dim c As Range

Set Rng = Range("A2:A20,E2:E20")

If Intersect(Target, Rng) Is Nothing Then GoTo ext

For Each c In Rng
If Not IsEmpty(c) Then
c.Offset(, 1).Value = Now
Else
c.Offset(, 1).ClearContents
End If
Next
Rng.Offset(, 1).EntireColumn.AutoFit
ext:
Application.EnableEvents = True
End Sub
---
（１）範囲拡張
Set Rng = Range("A2:A20,E2:E20")
（２）Application.EnableEvents = Falsewo
をいれた。
c.Offset(, 1).Value = Now
でＣｈａｎｇｅイベントの中にこないように
同時にIf Intersect(Target, Rng) Is Nothing Then GoTo ext
に変えてApplication.EnableEvents = True
を通るように
（３）For Each c In Intersect(Target,Rng)
を無駄を省いた。
For Each c In Rng
で良いようだ。

この回答へのお礼

無事、出来上がりました。
どうもありがとうございました。

お礼日時：2011/04/20 10:48

No.4 回答者： imogasi 回答日時： 2011/04/15 21:50

#3です。

もっとコードを省いて
Private Sub Worksheet_change(ByVal Target As Range)
Application.EnableEvents = False
Dim Rng As Range
Set Rng = Range("A2:A20,E2:E20")

If Intersect(Target, Rng) Is Nothing Then GoTo ext

Target.Offset(, 1).Value = Now

Rng.Offset(, 1).EntireColumn.AutoFit
ext:
Application.EnableEvents = True
End Sub
で良いのではないかと思いました。これで結果が、都合悪いですか。

この回答へのお礼

どうもありがとうございました。

お礼日時：2011/04/20 10:50

No.2 回答者： xls88 回答日時： 2011/04/15 18:47

Set Rng = Range("A2:A20")

を
Set Rng = Range("A2:A20, E2:E20")
として様子をみてください。

この回答へのお礼

どうもありがとうございました。

お礼日時：2011/04/20 10:49

No.1 回答者： keithin 回答日時： 2011/04/15 18:45

変更前：

Set Rng = Range("A2:A20")

変更後：ご相談に書かれたとおり
Set Rng = Range("A2:A20,E2:E20,F2:F20")

しかし実際には，E2:E20とF2～F20では全然ダメなのは明白ですね。
倣って適切に修正し，利用して下さい。

この回答へのお礼

どうもありがとうございました。

お礼日時：2011/04/20 10:49