- ベストアンサー
VBA CHANGEイベントに複数イベントを書き込む方法
hotosysの回答
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
関連するQ&A
- VBA changeイベントを複数入れたい
VBA changeイベントを複数入れたい VBAは初心者で、以前もこちらでお世話になりました。 F4セルに入力した際、VLOOKUPで検索し、該当がなければメッセージボックスを出し、 該当があれば、そのまま次に進む、というchangeイベントが既にあります。 ここに、E４セルに入力した数字が、同じシートのＥ列５行目以下と重複していた場合、 エラーメッセージを出す、とのをつけたしたいと思っています。 IFを使えばいい、ということはわかるのですが、どこに入れたらいいのかがわからず・・・。 すでにあるVBAは以下のとおりです。 Private Sub Worksheet_Change(ByVal Target As Range) '処分受託者（入力用名称）を入力して、処分業者名簿になければエラーメッセージを出す。 Dim rang1 As Range Dim rang2 As Range Dim 処分受託者名称 As String Dim LastRow As Long LastRow = Worksheets("処分業者名簿").Cells(Rows.Count, "b").End(xlUp).Row Set rang2 = Worksheets("処分業者名簿").Range("b4:ｂ" & LastRow) Set rang1 = Range("f4") If Intersect(Target, rang1) Is Nothing Then Exit Sub On Error Resume Next 処分受託者名称 = WorksheetFunction.VLookup(Target.Value, rang2, 1, 0) If Err.Number > 0 Then MsgBox Target.Value & " はありません" Range("f4").Select Else End If End Sub この、どこに重複の場合はエラーメッセージを出す、というのを入れればいいのか、 教えてください・・・。
- ベストアンサー
- Visual Basic
- VBAでChangeイベントを使いたい
今エクセルで出納を作ってます。 シート1には Ａ日付 Bコード C金額 D 消費税区分 E 金額 F,G,H,Iにも同様に貸方科目を入れてます。 シート2にはAコードB科目を上から下にずっといれてます。 それで借方金額Ｃの金額をEに飛ばすこと VLOOKUPでＢのコードに対応する科目を表示すること 上記をChangeイベントでやりたいのですが、金額転記はうまくいったのですが、 VLOOKUPの方が標準モジュールではうまくいくものの、シートモジュールに移すとうまく 行きません。おそらく根本的な理解がかけてるからだと思います。 今の記述は下記 シート1に Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row = 1 Or Target.Row > 100 Then Exit Sub If Target.Column <> 5 Then Exit Sub Dim Cnt As Long For Cnt = 2 To 100 Range("I" & Cnt).Value = Range("E" & Cnt).Value Next Cnt If Target.Row = 1 Or Target.Row > 100 Then Exit Sub If Target.Column <> 3 Then Exit Sub End Sub 標準モジュールに Option Explicit Sub 科目() Dim シート1 As Worksheet Dim シート2 As Worksheet Set シート1 = Worksheets("出納") Set シート2 = Worksheets("科目") Dim myR On Error GoTo ErrorHandler myR = Application.WorksheetFunction.VLookup(シート1.Range("B2"), シート 2.Range("A2:B87"), 2, False) シート1.Range("C2").Value = myR Exit Sub ErrorHandler: シート1.Range("C2").Value = "該当無し" End Sub 大変素人な質問ですみませんが、ご回答いただけると嬉しいです。 基礎の本やレファレンス本は見たのですが、標準モジュールでできること がなぜシートモジュールでできないかが全く分かりません。 よかったらお教えください。
- 締切済み
- 財務・会計・経理
- VBA changeイベントにてVLOOKUPで検索する方法とエラーの
VBA changeイベントにてVLOOKUPで検索する方法とエラーの場合の方法 VBAは半年ほど独学で勉強してきましたが、どうにもならなくなったので、質問させてください。 以下、１つのブックです。 シート１＜管理台帳＞ ４行目を入力行として、 B C D E F G H I J K L 伝票番号、日付、顧客名、顧客住所、集配地名称、集配地住所、数量A、数量B、数量C、備考、コメント などを入力。 マクロを使い、５行目以降にリストを追加。 （これはなんとか自分で作成できました） シート２＜住所録＞ おもな顧客の住所録。 シート１のD4セルに顧客名を入力すると、このリストから検索して、住所、主な集配地名称、住所をE4～G4に。 （これもなんとかできました。） ここからがどうしてもできないのですが。 シート３＜A伝票＞（シート１の数量Aの集計作業等の為） K列に伝票番号を入力すると、シート１＜管理台帳＞から検索して、 L列に顧客名、M列に数量A、N列に備考、O列にコメントを表示したいんですが。 どうしてもうまくいきません。 自分で考えた末、伝票番号が文字列になっているのがいけないのかな？と思ったのですが・・・。 どう対処したらいいのかわかりません。 伝票番号は10桁。０からはじまるものもあるので、文字列として扱いたいです。 また、もし、伝票番号シート１に入力されていなかった場合、エラーメッセージを表示したいのですが・・・。 いろいろ試してみましたが、知識不足でなんともなりませんでした。 どなたかご指導いただけませんか？？ めちゃくちゃですが、下に自分なりに作ったコードをのせます。 新年度から使いたい、と思っていたものなので、少し、急いでおります。 どうか、よろしくお願いします。 Private Sub Worksheet_Change(ByVal Target As Range) '伝票を Ｋ列に入力すると、管理台帳から検索。 Dim rang1 As Variant Dim rang2 As Variant Dim 顧客名 As String Dim 数量 As String Dim 備考 As String Dim コメント As String Set rang1 = Columns("k") Set rang2 = Worksheets("管理台帳").Range("B5:X20").Value If Intersect(Target, rang1) Is Nothing Then Exit Sub Application.EnableEvents = False 顧客名 = Application.WorksheetFunction.VLookup(Target.Value, rang2, 2, 0) If TypeName(顧客名) <> "error" Then Target.Offset(, 1) = 顧客名 数量 = Application.WorksheetFunction.VLookup(Target.Value, rang2, 12, 0) If TypeName(数量) <> "error" Then Target.Offset(, 2) = 数量 備考 = Application.WorksheetFunction.VLookup(Target.Value, rang2, 18, 0) If TypeName(備考) <> "error" Then Target.Offset(, 3) = 備考 コメント = Application.WorksheetFunction.VLookup(Target.Value, rang2, 20, 0) If TypeName(コメント) <> "error" Then Target.Offset(, 4) = コメント Else End If End If End If End If Application.EnableEvents = True End Sub
- ベストアンサー
- Visual Basic
- VBA Changeイベントのエラー
エクセルで簡単な計算書を作成しています。（マクロ初心者） ちなみにこのコードは自分で作成したものではなく、人から聞いていじってみました。 Private Sub Worksheet_Change(ByVal Target As Range) '一度に複数セルの値が変更された場合は終了 '（A5:C5を選択しDeleteも含みます。） If Target.Count > 1 Then Exit Sub If Intersect(Target, Me.Range("H170:K170", "H171:K171","C76")) Is Nothing Then Exit Sub Application.EnableEvents = False '数値かつ空白以外の場合 If IsNumeric(Target.Value) And Target.Value <> "" Then Me.Range("M170").Formula = "=if(iserror(H170*I170*J170*K170),""-"",H170*I170*J170*K170)" '空白の場合 ElseIf Target.Value = "" Then Me.Range("H170:K170,M170").Value = "-" End If Application.EnableEvents = True Application.EnableEvents = False '数値かつ空白以外の場合 If IsNumeric(Target.Value) And Target.Value <> "" Then Me.Range("M171").Formula = "=if(iserror(H171*I171*J171*K171),""-"",H171*I171*J171*K171)" '空白の場合 ElseIf Target.Value = "" Then Me.Range("H171:K171,M171").Value = "-" End If Application.EnableEvents = True Application.EnableEvents = False '空白の場合 If Target.Value = "" Then Me.Range("D76:K76","C76").Value = "-" End If Application.EnableEvents = True End Sub H170、I170、J170、K170のどれかに数値の入力があった場合、M170に計算式を入力。 H170、I170、J170、K170のどれかの値をDELETEキーでクリアした場合、H170、I170、J170、K170、M170に"-"を入力。 その他に似たような処理がたくさん出てくるので、H171の処理とC76をDELETEキーでクリアした場合の処理を自分で考えて作ってみたのですが、うまく実行されません。H171～の処理はうまくいったので単純にコードをどんどん追加していけば動くと思ったんですが、いろいろ調べてもどうも方法がわからず進みません・・・ 解決してもらえるでしょうか・・
- ベストアンサー
- オフィス系ソフト
- ２つのVBAを組み合わせる方法
お世話になります、２つのVBAを組み合わせる方法で迷っています。 １つ目が Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long If Intersect(Target, Range("C1,B9:B39")) Is Nothing Or Target.Count > 1 Then Exit Sub Application.EnableEvents = False With Target If .Column = 3 Then myNum = WorksheetFunction.Max(Range("B9:B39")) If IsDate(.Value) Then For i = 9 To 39 If Cells(i, "A").Value = "" Then Cells(i, "B").Value = "" Else Cells(i, "B") = myNum + i - 8 End If Next i End If Else i = .Row If .Value = "" Then Range(Cells(i + 1, "B"), Cells(39, "B")).ClearContents Else For k = i + 1 To 39 If Cells(k, "A").Value = "" Then Cells(k, "B").Value = "" Else Cells(k, "B") = Cells(k - 1, "B") + 1 End If Next k End If End If End With Application.EnableEvents = True End Sub です。 ２つめが Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = True If Intersect(Target, Range("R8:R38")) Is Nothing Then Exit Sub Application.EnableEvents = False Range(Cells(Target.Row, 18), Cells(39, 18)).Value = Target.Value Application.EnableEvents = True End Sub です。２つのPrivate Sub Worksheet_Change(ByVal Target As Range)イベントのVBAですが、どのようにして組み合わせれば良いのでしょうか？
- ベストアンサー
- Excel（エクセル）
- VLookupで一致しなかった時のVBAでの処理
On Error ～を使わないで、 VLookup()で一致しなかった時の処理をさせたいのですが どのように記述すればよいでしょうか。 例えば、以下のようなコードの場合、 一致したデータがない時にyに-1を代入するには 以下のコードをどのように記述すればよいのでしょうか。 --------------------- Dim x As Integer Dim y As String x = 7 y = Application.WorksheetFunction.VLookup(x, Worksheets("Sheet1").Range("A1:B100"), 2, False) --------------------- 以下はいずれもエラーになりますが、以下のような感じで処理がしたいです。 --------------------- If IsError(Application.WorksheetFunction.VLookup(x, Worksheets("Sheet1").Range("A1:B100"), 2, False)) Then y = -1 Else y = Application.WorksheetFunction.VLookup(x, Worksheets("Sheet1").Range("A1:B100"), 2, False) End If --------------------- If Application.WorksheetFunction.IsNA(Application.WorksheetFunction.VLookup(x, Worksheets("Sheet1").Range("A1:B100"), 2, False)) Then y = -1 Else y = Application.WorksheetFunction.VLookup(x, Worksheets("Sheet1").Range("A1:B100"), 2, False) End If --------------------- y = Application.WorksheetFunction.IfError(Application.WorksheetFunction.VLookup(x, Worksheets("Sheet1").Range("A1:B100"), 2, False), -1) --------------------- なお、以下のように本来エラーではない処理で On Error Resume Nextを使うのは、 本当のエラーの処理と混同するため不可 --------------------- On Error Resume Next y = Application.WorksheetFunction.VLookup(x, Worksheets("Sheet1").Range("A1:B100"), 2, False) If Err <> 0 Then y = -1 On Error GoTo 0 ---------------------
- ベストアンサー
- Excel（エクセル）
- エクセルVBAのイベントで質問です。
ダブルクリックイベントで、G12:G31の範囲の文字列をB10:B27の範囲(最下行)に入れていくものを使っていますが、新たにH12:H31にある文字列もダブルクリックするとC10:C27の範囲(最下行)に入れていけるようにしたいと思います。 どのようにすればいいでしょうか。 ご存知の方いらっしゃればお教えいただけると助かります。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, _ Cancel As Boolean) Dim i As Long Dim flg As Boolean If Intersect(Target, Range("G12:G31")) Is Nothing Then Exit Sub If IsEmpty(Target.Value) Then Exit Sub With Worksheets("シートＡ") For i = 10 To 27 If .Range("B" & i).Value = "" Then .Range("B" & i).Value = Target.Value flg = True Exit For End If Next i If flg = False Then MsgBox .Name & " がいっぱいです。" End If End With Cancel = True End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル2013VBA Changeイベント 選択
お世話になります。一度質問を締め切ったのですが、色々やっているうちに問題がでてきたので再投稿いたしました。Excel2013です。 計画のファイルがあります。 例えば、"テーブル"シートのA列に品物A、品物B、品物C・・・、と入力されていて、B列にはA列の品物に対応して、付属A、付属B、付属Aなどと入力されているとします。実際は、品物数は数千種類あります。（この例の場合は、品物Aと品物Cは同じ付属を使う） "計画"シートには、A列にデータの入力規則のリストより、A社やB社・・・を選択し、 さらにB列は入力規則のリストより、=INDIRECT(B2)などといれて、A列の入力規則に対して品物Aや品物B・・・などを選択します。選択するようにしています。 それで、品物Aを選んだら、その下の行に付属Aとか自動ででるようにしたいと思っています。 （列は増やしたくありません） 入力範囲のどこでも選択をできるようにしておきたいので、入力範囲にはすべてリストが設定されており、数式を入れることはできません。 とりあえず、品物を入力する範囲は、C2:C25,G2:G25範囲です。 その状態で、 とりあえずご教授いただいて下記コードまでたどりついていき通常は大丈夫なのですが、B列とC列をまとめて選択コピーして貼り付けると、付属Aと出るべきところが何も起こりません。アクティブセルが隣の列を選択しているためだと思われますが、どうすればよいか分かりません。 Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = True On Error GoTo mExit Application.EnableEvents = False If Intersect(Target, Range("C2:C25,G2:G25")) Is Nothing Then Application.EnableEvents = True Exit Sub Else If Target.Offset(1, 0).Value = "" Then Target.Offset(1, 0).Value = Application.WorksheetFunction.VLookup(Target.Value, Sheets("テーブル").Range("B:C"), 2, False) Application.EnableEvents = True End If End If Application.EnableEvents = True Exit Sub mExit: Application.EnableEvents = True End Sub 度々お手数をおかけいたしますが、ご教授ください。
- ベストアンサー
- Excel（エクセル）
- VBAのchangeイベントについて
初質問＆VBA初心者のため記述が変なところがあると思いますがご了承ください。 現在changeイベントを使用してイメージした通りに動いてくれている（中身はぐちゃぐちゃですが・・・）のですがこれをすべてのシートでも機能するようにしたいのですが何かいい方法はないでしょうか。 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$A$1" Then Exit Sub rc = MsgBox("納車日を更新してもよろしいですか？", vbYesNo + vbQuestion, "確認") If rc = vbYes Then MsgBox "納車日を更新しました" RID = ActiveSheet.Name Set b = Worksheets("シート名").Cells.Find(What:=RID) RID_height = Worksheets("シート名").Cells.Find(RID).Row RID_width = Worksheets("シート名").Cells.Find(RID).Column ThisWorkbook.Worksheets("シート名").Cells(RID_height, 10).Value = Date Else MsgBox "処理を中断します" End If End Sub
- ベストアンサー
- Excel（エクセル）
- VBAでコードの編集が上手くいきません
先日、ご回答頂いたコードを元に自分でいじっているのですが上手く行きません 自分が変更したコード シート1→シート名：変更箇所 Private Sub worksheet_change(ByVal Target As Excel.Range) If Target.Address <> "$C$40" Then Exit Sub If Target = "" Then Worksheets("リスト").AutoFilterMode = False: Exit Sub Worksheets("リスト").Range("A:C").AutoFilter field:=1, Criteria1:=Target.Value If Target.Address <> "$C$42" Then Exit Sub If Target = "" Then Worksheets("リスト").AutoFilterMode = False: Exit Sub Worksheets("リスト").Range("A:C").AutoFilter field:=1, Criteria1:=Target.Value If Target.Address <> "$C$44" Then Exit Sub If Target = "" Then Worksheets("リスト").AutoFilterMode = False: Exit Sub Worksheets("リスト").Range("A:C").AutoFilter field:=1, Criteria1:=Target.Value End Sub シート2→シート名：リスト Private Sub worksheet_change(ByVal Target As Excel.Range) Dim i As Long, c As Long Dim h As Range, ha As Range Dim myDic As Object Set ha = Application.Intersect(Target, Range("A:C")) If ha Is Nothing Then Exit Sub Set ha = Application.Intersect(ha.EntireColumn, Range("1:1")) For Each h In ha Set myDic = CreateObject("Scripting.Dictionary") If h.Column = 1 Then c = 3 'A列→C列 If h.Column = 2 Then c = 4 'B列→D列 If h.Column = 3 Then c = 6 'C列→F列 On Error Resume Next For i = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row If Cells(i, h.Column) <> "" Then myDic.Add Cells(i, h.Column).Value, Cells(i, h.Column).Value End If Next i With Worksheets("変更箇所").Cells(40, c).EntireColumn.Validation .Delete .Add Type:=xlValidateList, Formula1:=Join(myDic.keys, ",") End With Set myDic = Nothing Next End Sub シート1において$C$40または$C$42または$C$44のいずれかを変更した場合 最後に変更したセルに対し、シート2にオートフィルタ―がかかる様にしたいと思っています。 試しにシート1を以下のように編集したところ、思った動作を行ったのですが $C$40または$C$42または$C$44のいずれかのセルを空白にすると エラーがでてしまいます。 Private Sub worksheet_change(ByVal Target As Excel.Range) If Target = "" Then Worksheets("リスト").AutoFilterMode = False: Exit Sub Worksheets("リスト").Range("A:C").AutoFilter field:=1, Criteria1:=Target.Value If Target = "" Then Worksheets("リスト").AutoFilterMode = False: Exit Sub Worksheets("リスト").Range("A:C").AutoFilter field:=1, Criteria1:=Target.Value If Target = "" Then Worksheets("リスト").AutoFilterMode = False: Exit Sub Worksheets("リスト").Range("A:C").AutoFilter field:=1, Criteria1:=Target.Value End Sub Then Exit Subをどう編集すれば上手く動作するでしょうか？
- ベストアンサー
- オフィス系ソフト
お礼
＞EからXに順に入力して・・・」の文の意味が、VBAで何かをして欲しいのか何もしないくていいのかわかりません。 どのセルから入力していくか、という説明が必要かと思い、書かせていただきました。 わかりにくいことを書いてしまい、申し訳ありませんでした。 こちらの回答で、思った通りのことができました。 本当にありがとうございました。