• ベストアンサー
  • すぐに回答を!

2つのVBAを組み合わせる方法

お世話になります、2つのVBAを組み合わせる方法で迷っています。 1つ目が 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 です。 2つめが 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 です。2つのPrivate Sub Worksheet_Change(ByVal Target As Range)イベントのVBAですが、どのようにして組み合わせれば良いのでしょうか?

共感・応援の気持ちを伝えよう!

  • 回答数1
  • 閲覧数466
  • ありがとう数1

質問者が選んだベストアンサー

  • ベストアンサー
  • 回答No.1
  • kybo
  • ベストアンサー率53% (349/647)

>If Intersect(Target, Range("C1,B9:B39")) Is Nothing Or Target.Count > 1 Then Exit Sub 条件に合わない場合、Exit Subで抜けるのではなく、条件に合う場合、実行するという風に直せば考え方として簡単です。 例:Not Intersect(Target, Range("C1,B9:B39")) Is Nothing Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long If Not Intersect(Target, Range("C1,B9:B39")) Is Nothing And Target.Count = 1 Then 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 ElseIf Not Intersect(Target, Range("R8:R38")) Is Nothing Then Application.EnableEvents = False Range(Cells(Target.Row, 18), Cells(39, 18)).Value = Target.Value Application.EnableEvents = True End If End Sub

共感・感謝の気持ちを伝えよう!

質問者からのお礼

凄いです、確かに2つのVBAが作動する様になりました。 この度はありがとうございました、非常に助かります。

関連するQ&A

  • 連続データのVBAの質問

    お世話になります。 Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long If Range("C1") <= Date - Day(Date) Then Exit Sub If Not Intersect(Target, Range("C1,B9:B39")) Is Nothing And Target.Count = 1 Then 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 ElseIf Not Intersect(Target, Range("R8:R38")) Is Nothing Then Application.EnableEvents = False Range(Cells(Target.Row, 18), Cells(39, 18)).Value = Target.Value Application.EnableEvents = True End If End Sub これはセルC1に年月を表記させ、そのC1セルの年月を変更した場合B9&#65374;B39のセルが自動で連続データの数字を記入し、B9&#65374;B39のどこかのセルを空白にすると、そのセル以降も空白になります。 そこで質問ですが、例えばB14の数字を消すとB15&#65374;39まで空白のセルになります。そして、B20に1と入力するとB21&#65374;39に連続データの数字が自動記入されます。 そしてC1の年月を次の月に更新した際は、B39で示された数字以降の連続データをB9に表示させるには、どうすれば良いでしょうか?

  • 連続データのVBAの質問

    お世話になります。 Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long If Not Intersect(Target, Range("C1,B9:B39")) Is Nothing And Target.Count = 1 Then 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 ElseIf Not Intersect(Target, Range("R8:R38")) Is Nothing Then Application.EnableEvents = False Range(Cells(Target.Row, 18), Cells(39, 18)).Value = Target.Value Application.EnableEvents = True End If End Sub これはセルC1に年月を表記させ、そのC1セルの年月を変更した場合B9&#65374;B39のセルが自動で連続データの数字を記入し、B9&#65374;B39のどこかのセルを空白にすると、そのセル以降も空白になります。 そしてR8&#65374;R38は、指定範囲のセルに数字を入力したら、そのセル以降の指定した範囲のセルに同じ数字を自動入力するVBAです。 そこで質問ですが、質問した現在は2013年12月ですが、日本時間の現在の年月以前の年月(今で言うと2013年11月以前)をC1に記入した場合はB9&#65374;B39の連続データの数字が切り替わらない様にするには、どうすれば宜しいでしょうか?

  • VBA初心者です

    VBA初心者です。 同じセルに数字を入れて足し算して行きたいんですが! 下記のVBA見つけたのですが、A1に数字を入れて答えがE1に出るんですが、同じ事を A2、A3、A4、A5答えもE2、E3......で増やしたいのですが、どうするか分かりません。 どなたか教えてください。 宜しくお願いします。 Private Sub Worksheet_Change(ByVal Target As Range) Dim inp, outp As String inp = "$A$1" outp = "E1" Application.EnableEvents = False If Target.Address = inp Then Range(outp).Value = Range(outp).Value + Target.Value If Target.Value <> "" Then ActiveCell.Offset(-1, 0).Select Else Range(outp).Value = 0 End If End If Application.EnableEvents = True End Sub

  • セル空白時に月を変更した時の累計使用日数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")) myDate = Range("C1").Value Range("A9:A39").ClearContents If IsDate(.Value) Then ' ----------A列に日にちを入力---------- For i = 1 To 31 If Month(myDate + i - 1) = Month(.Value) Then Cells(i + 8, "A").Value = Day(myDate + i - 1) Else Cells(i + 8, "A").Value = "" End If Next i ' ----------B列の空白条件---------- If Range("B39").Value = "" Or Range("B38").Value = "" Or Range("B37").Value = "" Or Range("B36").Value = "" Then Range("B9:B39").ClearContents Application.EnableEvents = True End End If ' ----------B列に連続値の入力---------- 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 End With Application.EnableEvents = True End Sub 内容はC1には年月(2013年12月)を表示させています。 そして、B9&#65374;B39には累計使用日数を表示するVBAを組んでいます。 B9&#65374;B39間に適当な数字を入力すると、連続データの数字が入力されるようになります。 そして、C1セルの日付を変更しても連続データが継続して表示されるVBAです。 B39が空白表示の場合(小月ならB38で2月ならB36かB37)でC1セルの年月を変更した場合、連続データを表示させず空白セルを表示させるVBAを組んだつもりです。 しかし、上手く作動しません。もうお手上げです。どこがおかしいのでしょうか?ご教授宜しくお願いします。

  • excel2007 VBで

    下記のマクロ作成して実際にセルにA、あるいは何かデータを入力しても下記イベント?が発生している気配がありません。 Application.EnableEvents = Falseの行がなにか問題なのでしょうか。実プログラムは If Target.Value = "A" Or Target.Value = "A" Thenの他にB、C、計算も含んでいるのですがApplication.EnableEvents = TrueはEnd Subの前行に入れてあります。 他に設定することがあるのでしょうか。どなたか教えてください。 Private Sub Worksheet_Change(ByVal Target As Range)    If Target.Count > 1 Then Exit Sub '複数セルの入力は無視 Application.EnableEvents = False '割込み停止 ’[B3] = 123 ’Stop If Target.Value = "A" Or Target.Value = "A" Then Target.Value = "A" End If Application.EnableEvents = True '割込み再開 End Sub excel2007 VB6.5です。

  • このマクロあっていますでしょうか?よろしくお願いいたします。

    ★sheetA Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$C$14" And Target.Address <> "$C$19" _ And Target.Address <> "$F$19" Then Exit Sub If Target.Address <> "$R$14" And Target.Address <> "$S$14" _ And Target.Address <> "$T$19" Then Exit Sub Application.EnableEvents = False With Sheets("B") .Range("F14").Value = Range("C14").Value .Range("F17").Value = Range("C19").Value .Range("F20").Value = Range("F14").Value .Range("F23").Value = Range("F19").Value End With With Sheets("C") .Range("F13").Value = Range("R14").Value .Range("F14").Value = Range("S14").Value .Range("F18").Value = Range("T19").Value End With Application.EnableEvents = True End Sub ★sheetB Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$F$14" And Target.Address <> "$F$17" _ And Target.Address <> "$F$23" Then Exit Sub Application.EnableEvents = False With Sheets("A") .Range("C14").Value = Range("F14").Value .Range("C19").Value = Range("F17").Value .Range("F19").Value = Range("F23").Value End With Application.EnableEvents = True End Sub ★sheetC Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$F$13" And Target.Address <> "$F$14" _ And Target.Address <> "$F$18" Then Exit Sub Application.EnableEvents = False With Sheets("A") .Range("R14").Value = Range("F13").Value .Range("S14").Value = Range("F14").Value .Range("T19").Value = Range("F18").Value End With Application.EnableEvents = True End Sub

  • 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

    Private Sub Worksheet_Change(ByVal Target As Range) Dim R As Range ActiveSheet.Protect UserInterfaceOnly:=True Set R = Union(Range("D5:D38"), Range("E5:E38"), Range("T5:T38")) With Target If Intersect(.Cells, R) Is Nothing Then Exit Sub Application.EnableEvents = False Range(Cells(.Row, .Column), Cells(38, .Column)).Value = .Value Application.EnableEvents = True End With End Sub この様なコードがあるのですが範囲を変更したいと思います。 D5:D38は上記コードのままで良いのですが、E5;E38はE5:E36に、T5:T38はT5:T36に変更するにはどうすれば良いのでしょうか?

  • Excelで入力数値の桁数に応じてフォントサイズを変える方法

    VBAの初心者です。 Excelで列幅=3の、列数の多い表を作りました。 ある程度見やすいフォントサイズ9pにすると、桁数の多い数値が####となってしまいます。 その場合には、8pに変えて4桁まで見られるようにしたいのです。 そこで、下記のプロシージャを組み込んでみました。 Private Sub Worksheet_Change(ByVal Target As Range) Dim c As Range, r As Range Set r = Application.Intersect(Me.Range("B2:BJ10"), Target) If r Is Nothing Then Exit Sub Application.EnableEvents = False For Each c In r If IsNumeric(c.Value) Then If LenB(c.Value) > 5 Then c.Font.Size = 8 Else c.Font.Size = 9 End If End If Next c Application.EnableEvents = True End Sub ところが、実際に数値を入れてみると、どういうわけか 1.2 など3バイトの数値も8pになってしまいます。 LenB(1.2)=3 であるのに、どういう現象なのかわかりません。 いきなり If LenB(c.Value) > 5 Then としたのが間違っているのかと思うのですが、どう直したらよいか教えて下さい。よろしくお願いします。

  • エクセル マクロ 初心者です

    エクセルマクロ初心者です。 以下の2つの Private Sub Worksheet_Change(ByVal Target As Range)を1つのシートで実行させたいのですが、 当方、初心者なので組み合わせ方が分かりません。 よろしくお願いします。 ===No1=== Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Target = StrConv(Target, vbUpperCase) Application.EnableEvents = True End Sub ===No2=== Private Sub Worksheet_Change(ByVal Target As Range) Dim Ans As Integer If Target.Count = 1 Then Ans = MsgBox("コピーは禁止!!", vbCritical) MsgBox "データを消去します。" With Application .EnableEvents = False .Undo .EnableEvents = True End With End If If Target.Count = 1 Then Exit Sub Else MsgBox “複数セルのコピー禁止!" With Application .EnableEvents = False .Undo .EnableEvents = True End With End If End Sub ------------ 上記の2つを1つのシートで動作させたいのですが、うまくいきません。 単体では、動作します。