VBA CHANGEイベントに複数イベントを

いつもお世話になっています。

色々しらべて試してみたんですが、うまくいかないんで教えてください。


CHANGEイベントに複数のイベントを書き込みたいんですが。

今現在、問題なく動いている以下のイベントがあります。

(1)
Private Sub Worksheet_Change(ByVal Target As Range)



Dim rang3 As Range
Dim rang4 As Range
Dim ■■ As String
Dim LastRow1 As Long

LastRow1 = Worksheets("○○").Cells(Rows.Count, "b").End(xlUp).Row
Set rang4 = Worksheets("○○").Range("b:I" & LastRow)
Set rang3 = Range("h4")

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


On Error Resume Next

■■ = WorksheetFunction.VLookup(Target.Value, rang4, 2, 0)
If Err.Number > 0 Then
MsgBox Target.Value & "はありません。基本情報台帳に入力してください。"



Range("h4").Select


Else

Application.EnableEvents = False

Range("I4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 2, False)
Range("j4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 3, False)
Range("k4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 7, False)
Range("l4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 8, False)
Range("m4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 5, False)

Application.EnableEvents = True



Range("K4").Select



End If



End Sub


このシートにもう一つ、イベントを入れたいのですが。

(2)
If Target.Count > 1 Then Exit Sub

If Intersect(Target, Range("E4")) Is Nothing Then

Exit Sub


Else

If Range("e4").Value = "1" Then
Target.Offset(0, 19).Value = "☆"

End If

どこに入れればいいのかわかりません。


(3)

また、(2)のイベントの他に、
(1)のＶＬＯＯＬＵＰが実行され、尚且つ(2)のイベントのＥ４が値が１だった場合、Ｙ４にＨ４の値を入れたいのですが・・・。



(2)のみなら動くことは確認できましたが、(1)のｅｘｉｔ　ｓｕｂ　の直前に入れたり、ｅｎｄ　ｉｆの前に入れたりしましたが、片方は動くが、もうひとつが動かないです。
(3)については、まったくわかりません。

マクロについて、自分でネットで勉強した程度なので、基本がわかっていないからなのでしょうが・・・。


どなたか、教えてください。
お願いします。

No.5 ベストアンサー 回答者： hotosys 回答日時： 2010/12/22 10:27

No.3です。

こんなのでしょうか？
参照する"△△"シートを"Sheet2"としています。
>マクロがあるシート（△△）への入力は、４行目にＥ～Ｘ（左から右）へと順に入力していきます。
>Ｅ４が空白のままで、Ｈ４に入力した際は、Ｙ４にＨ４の値を入れたい場合は、どうすればいいですか？
E4またはH4が変更された時にY4を変更する条件と値はわかりましたが、その前の「EからXに順に入力して・・・」の文の意味が、VBAで何かをして欲しいのか何もしないくていいのかわかりません。

それとシートの値を変更する条件が増えてゆくと、条件によってはWorksheet_Changeが多重にかかる場合が起きてくるので、今は不要ですが、Application.EnableEventsでの制御が必要になってくる可能性が出てくるかもしれません。


Private Sub Worksheet_Change(ByVal Target As Range)
changeH4 Target
changeE4 Target
End Sub

'(1)の処理
Sub changeH4(ByVal Target As Range)
Dim rng As Range
'処理条件
'変更されたセルがH4セルで値があったら実行 (それ以外は終了)
If Target.Address <> "$H$4" Then Exit Sub 'H4以外のchangeイベントなら終了
If Target.Value <> "" Then '空白でなく
'"△△"シート(Sheet2)のB列から探してなかったらエラーメッセージ出してH4選択
Set rng = Worksheets("Sheet2").Columns("B").Find(Target.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not rng Is Nothing Then
Range("I4").Value = rng.Offset(0, 1).Value
Range("J4").Value = rng.Offset(0, 2).Value
Range("K4").Value = rng.Offset(0, 6).Value
Range("L4").Value = rng.Offset(0, 7).Value
Range("M4").Value = rng.Offset(0, 4).Value
Range("K4").Select
checkY4 '転記した場合の追加イベント
Exit Sub
End If
MsgBox Target.Value & "はありません。基本情報台帳に入力してください。"
End If
Range("H4:M4").Value = ""
Range("H4").Select
End Sub

'(2)の処理
Sub changeE4(ByVal Target As Range)
'E4が変更されたとき
If Target.Address <> "$E$4" Then Exit Sub
'1ならE4を右に19移動したセル(X4)を☆
If Target.Value = "1" Then
Range("X4") = "☆"
checkY4 '☆を書いた場合の追加イベント
Else
Range("X4") = ""
End If
End Sub

'(3)の処理
Sub checkY4()
Dim y4 As String
y4 = ""
'(1)のＶＬＯＯＬＵＰが実行され、尚且つ(2)のイベントのＥ４が値が１だった場合、Ｙ４にＨ４の値を入れたい。
If Range("H4").Value <> "" Then
If Range("E4").Value = "1" Then
y4 = Range("H4").Value
End If
End If
'Ｅ４が空白のままで、Ｈ４に入力した際は、Ｙ４にＨ４の値を入れたい場合
If Range("E4").Value = "" Then
If Range("H4").Value <> "" Then
y4 = Range("H4").Value
End If
End If
Range("Y4").Value = y4
End Sub

この回答へのお礼

＞EからXに順に入力して・・・」の文の意味が、VBAで何かをして欲しいのか何もしないくていいのかわかりません。

どのセルから入力していくか、という説明が必要かと思い、書かせていただきました。
わかりにくいことを書いてしまい、申し訳ありませんでした。

こちらの回答で、思った通りのことができました。
本当にありがとうございました。

お礼日時：2010/12/22 21:07

No.4 回答者： Wendy02 回答日時： 2010/12/21 22:58

#2の回答者です。

>おっしゃる通りです。
というように反応されても、どういうイベントをさせるのか、コードの説明まで書いても、きちんちした説明をしていただけなったようです。私は、単に分からないということを伝えただけにすぎません。もともと、イベントを置くシートすら、明示されていません。

私は、他人のマクロをみて直すほど、みっともないことはしたくありませんが、どうやら、E4をイベントにしているようです。ただ、直接、お返事がいただけなかったということで、一応、こちらでは、訂正はせずに、そのまま様子見に切り替えさせていただきます。

それは、また、イベントですから、同種の違った種類のコードを入れることは、トラブルの元にもなります。

>(1)の処理に「もし、Ｅ４が空白だったら・・・・」の処理を入れればいいと思うのですが・・・。
If Range("E4").Value ="" Then

ということでも、それは、全体に関わる問題なのか、それとも、部分的なものなのか、はっきりしません。何か、同じ繰り返しになってしまうように思います。このような初歩的なマクロでは、きちんとした説明をまとめて、分かるようにしていただければ、長引くことはないはずです。

この回答へのお礼

＞このような初歩的なマクロでは、きちんとした説明をまとめて、分かるようにしていただければ、長引くことはないはずです。

自分のしたいことがうまくまとめられず、すいません。

不愉快な思いをさせていたら、申し訳ありません。
最初に回答をいただけて、嬉しかったです。
ありがとうございました。

お礼日時：2010/12/22 20:48

No.3 回答者： hotosys 回答日時： 2010/12/20 21:47

一体いくつのシートを使っているのかわからないのですが、プログラムではこのVBAがあるシートと"○○"シートと"△△"シートの3枚のようだけれど、チェックしてデータを持ってくる"○○"シートと"△△"シートは同じシートでなければチェックの意味が無いような気もします。

一体いくつのシートを使っているのでしょう？
一応３つのシートを使っていて、このVBAがあるシートをSheet1、"○○"シートをSheet2、"△△"シートをSheet3としています。


Private Sub Worksheet_Change(ByVal Target As Range)
Worksheet_Change1 Target
Worksheet_Change2 Target
End Sub

'(1)の処理
Sub Worksheet_Change1(ByVal Target As Range)
Dim rng As Range
'処理条件
'変更されたセルがH4セルで値があったら実行 (それ以外は終了)
If Target.Address <> "$H$4" Then Exit Sub
If Target.Value = "" Then Exit Sub
'"○○"シート(Sheet2)のB列から探してなかったらエラーメッセージ出してH4選択
Set rng = Worksheets("Sheet2").Columns("B").Find(Target.Value, LookIn:=xlValues, LookAt:=xlWhole)
If rng Is Nothing Then
MsgBox Target.Value & "はありません。基本情報台帳に入力してください。"
Range("h4").Value = ""
Range("h4").Select
Exit Sub
End If
'"△△"シート(Sheet2)のB列から探してあったらその行の値をコピー
Set rng = Worksheets("Sheet3").Columns("B").Find(Target.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not rng Is Nothing Then
Range("I4").Value = rng.Offset(0, 1).Value
Range("j4").Value = rng.Offset(0, 2).Value
Range("k4").Value = rng.Offset(0, 6).Value
Range("l4").Value = rng.Offset(0, 7).Value
Range("m4").Value = rng.Offset(0, 4).Value
Range("K4").Select
additional_event '転記した場合の追加イベント
Else
Range("h4").Value = ""
Range("h4").Select
End If
End Sub

'(2)の処理
Sub Worksheet_Change2(ByVal Target As Range)
'E4が変更されたとき
If Target.Address <> "$E$4" Then Exit Sub
'1ならE4を右に19移動したセル(X4)を☆
If Target.Value = "1" Then
Range("X4") = "☆"
additional_event '☆を書いた場合の追加イベント
Else
Range("X4") = ""
End If
End Sub

'(3)の処理
Sub additional_event() '星を書いた場合の追加イベントif
If Range("H4").Value = "" Then Exit Sub
If Range("E4").Value <> "1" Then Exit Sub
Range("Y4").Value = Range("H4").Value
End Sub

この回答へのお礼

回答、ありがとうございます。

＞一体いくつのシートを使っているのかわからないのですが

文章がわかりづらく、すいません。

シートは、マクロがあるシート（△△）と、もう一枚（○○）の２枚です。
が、作っていただいたコードを転記したところ、希望道理の結果になりました。

ありがとうございます。


また、もうひとつ、お聞きしたいことがあるのですが・・・。

マクロがあるシート（△△）への入力は、４行目にＥ～Ｘ（左から右）へと順に入力していきます。
Ｅ４が空白のままで、Ｈ４に入力した際は、Ｙ４にＨ４の値を入れたい場合は、どうすればいいですか？

最初の質問にないことで申し訳ないのですが、教えていただけますか？

(1)の処理に「もし、Ｅ４が空白だったら・・・・」の処理を入れればいいと思うのですが・・・。

申し訳ありません。
お願いします。

お礼日時：2010/12/21 12:29

No.2 回答者： Wendy02 回答日時： 2010/12/20 19:15

>(3)についてが、動きません。

言葉の解釈通りなら、間違いないはずです。位置関係の問題だろうと思いますから、
以下のコードの説明を読んで修正してください。

動きませんと言われても、マクロは可動していますから、こちらでは確認できません。

>(3)
>また、(2)のイベントの他に、
>(1)のVLOOLUPが実行され、尚且つ(2)のイベントのE4が値が1だった場合、Y4にH4の値を入れたいのですが・・・。

しかし、この文章が、(2)に連動しているのではなく、(1)側のマクロに連動しているのか、または、まったく別のキーのイベントというならは、これは、話が違います。思惑と違うというのは、説明が抜けているのかと思います。

　　'E4を対象とする。
　ElseIf Not Intersect(Target, Range("E4")) Is Nothing Then　'(2)
　　　'E4 に1を入れる
　　If Target.Value = 1 Then　
　　　'X4に☆が入る
　　　Target.Offset(0, 19).Value = "☆"
　　　'もし、H4に値が入っていれば、
　　　If Target.Offset(0, 3).Value <> "" Then　'(3)　
　　　'Y4にH4の値が入る
　　　　Target.Offset(0, 20).Value = Target.Offset(0, 3).Value
　　　End If
　　End If
　End If

この回答へのお礼

遅くなり、申し訳ありません。
回答、ありがとうございます。

>(3)
>また、(2)のイベントの他に、
>(1)のVLOOLUPが実行され、尚且つ(2)のイベントのE4が値が1だった場合、Y4にH4の値を入れたいのですが・・・。

しかし、この文章が、(2)に連動しているのではなく、(1)側のマクロに連動しているのか、または、まったく別のキーのイベントというならは、これは、話が違います。思惑と違うというのは、説明が抜けているのかと思います。

おっしゃる通りです。
すいません。

(1)(2)(3)とも、値が変わった時、ＣＨＡＮＧＥイベントで発生させたいと思っておりました。
説明が足りず、申し訳ありませんでした。

お礼日時：2010/12/21 12:04

No.1 回答者： Wendy02 回答日時： 2010/12/19 19:26

私は、最後まで回答できないかもしれませんが、それだけはご了解ください。

私個人は、以下のような書き方はしませんが、一応、書き換えた部分は見てください。
細かな注意点を書こうかとは思いましたが、やめることにしました。

If Target.Count > 1 Then Exit Sub
これは、その目的の意味にもよりますが、通常、Changeイベントにするなら、先頭においてもよいかと思います。本来は、それとともに、その次の行に、If Target.Value ="" Then Exit を入れます。

おそらく、「実は、これはH列とE列を対象にしています」というかもしれませんが、それは、なるべくご自身で考えてください。ある程度は対応するように考えています。

'//
Private Sub Worksheet_Change(ByVal Target As Range)
　'Dim rang3 As Range '不要
　Dim rang4 As Range
　Dim rang5 As Range '加入
　Dim sText As Variant
　'Dim LastRow1 As Long　'不要
　If Target.Count > 1 Then Exit Sub
　Application.EnableEvents = False
　If Not Intersect(Target, Range("H4")) Is Nothing Then
　　With Worksheets("○○")
　　　Set rang4 = .Range("B1", .Cells(Rows.Count, "B").End(xlUp).Offset(, 7))
　　End With
　　On Error Resume Next
　　sText = WorksheetFunction.VLookup(Target.Value, rang4, 2, 0)
　　If Err.Number > 0 Then
　　　MsgBox Target.Value & "はありません。基本情報台帳に入力してください。"
　　　Range("H4").Select
　　　Set rang4 = Nothing
　　Else
　　 With Worksheets("△△")
　　　　 Set rang5 = .Range("B1", .Cells(Rows.Count, "B").End(xlUp).Offset(, 7))
　　 End With
　　　Range("J4").Value = WorksheetFunction.VLookup(Target.Value, rang5, 3, False)
　　　Range("K4").Value = WorksheetFunction.VLookup(Target.Value, rang5, 7, False)
　　　Range("L4").Value = WorksheetFunction.VLookup(Target.Value, rang5, 8, False)
　　　Range("M4").Value = WorksheetFunction.VLookup(Target.Value, rang5, 5, False)
　　　Range("K4").Select
　　　Set rang5 = Nothing
　　End If
　ElseIf Not Intersect(Target, Range("E4")) Is Nothing Then　'(2)
　　If Target.Value = 1 Then
　　　Target.Offset(0, 19).Value = "☆"
　　　If Target.Offset(0, 3).Value <> "" Then　'(3)
　　　　Target.Offset(0, 20).Value = Target.Offset(0, 3).Value
　　　End If
　　End If
　End If
　Application.EnableEvents = True
End Sub

この回答への補足

ありがとうございます。
後ほど、確認の上、報告させていただきます。

補足日時：2010/12/20 10:04

この回答へのお礼

遅くなり、申し訳ありません。
回答、ありがとうございます。

元からあるVBAについても、きれいに書き直していただき、ありがとうございます。


(2)については、問題なく動きました。ありがとうございます。

ですが・・・。
(3)についてが、動きません。


もしよろしければ、教えていただきたいです。

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

お礼日時：2010/12/20 17:00