『2箇所同時に実行したい』（ネットカフェ）
チェンジイベントマクロなんですが
B列を変更するとAI列にもB列の文字列がコピーされるのですが
2箇所にするとどうしてもうまく動作してくれないので
変更をお願いします
Selection.Copy
ActiveCell.Offset(0, 32).Range("B1").Select'-------AI列
'ここにもう一つ条件を追加したい
'ActiveCell.Offset(0, 40).Range("B1").Select------AQ列
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False'ここでデバックがかかってしまい止まってしまう。
＜ 使用 Excel：Excel2007、使用 OS：Windows10 ＞
チェンジイベントマクロの全体を省略せずに書いてもらえませんか？ Targetを制約するような条件はつけているのでしょうか？
チェンジイベントマクロのなかでセルを変更すると、それがまたChangeイベントを引き起こします。 そのことを考慮する必要があります。
（xyz） 2024/07/30(火) 23:11:44
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row < 12151 Then Exit Sub
If Target.Column = 2 Then
Selection.Copy
ActiveCell.Offset(0, 32).Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If Application.CutCopyMode = False
End Sub
（ネットカフェ） 2024/07/30(火) 23:22:01
エラーの原因はわかりませんでした。
それ以前に、基本的にところで勘違いがあるように見受けました。
(1)TargetとSelect,ActiveCellの違いを理解されていますか？
TargetはChangeがあったセル範囲、Selectは現在の選択範囲です。
例えば、入力後、カーソルを下に移動させる設定にしてあると、TargetとSelectは位置がずれます。
SelectはTargetのひとつ下のセルです。コピー元が意図に合っているものか確認して下さい。
(2)
| ActiveCell.Offset(0, 32).Range("B1").Select'-------AI列
| 'ここにもう一つ条件を追加したい
| 'ActiveCell.Offset(0, 40).Range("B1").Select------AQ列
ActiveCellは動きますから、二番目の処理ではAQ列にはなりません。確認してください。
（ActiveCell.Offset(0, 32).Range("B1")の意図もよくわかりませんでした）
想像を交えていますので、そちらでよく確認して下さい。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
If Target.Row < 12151 Then Exit Sub
If Target.Column = 2 Then
Target.Copy
Set rng = Union(Target.Offset(0, 33), Target.Offset(0, 41))
Application.EnableEvents = False 'イベントの捕捉を一時停止
rng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.EnableEvents = True 'イベントの捕捉を再開
With rng.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Application.CutCopyMode = False
End If
End Sub
（xyz） 2024/07/31(水) 06:36:45
Offset(0, 41))のTarget「41」で同一行の右へ移行したAQ列に意図したことが無事移動しました。
難しかったです。
この度はどうもありがとうございました。
（ネットカフェ） 2024/07/31(水) 06:53:20
（xyz） 2024/07/31(水) 07:30:15
■１
ChangeイベントのTargetは、（飛び飛びのセルを含む）複数のセル（範囲）になることがあり得ます。
このとき「Target.Row」「Target.Column」は、それぞれ一番左上のセルのことになりますので、複数セルが同時に変更されることがあるのであれば、判定に使うのはお勧めできません。
（削除や消去、貼付などでいっぺんに書き換わることは往々にしてあります）
■２
既にあるように「Target」「Selection」「ActiveCell」それぞれの違いをちゃんと理解することお勧めします。
xyzさんの説明と重複する部分もありますが、私なりに説明すると
Target・・・・・書き換えのあったセル。飛び飛びの複数セル（範囲）であることがあり得る。
Selection ・・・現在選択しているもの。セル範囲以外のものでもSelectionになり得る。（たとえばシェイプなど）
セルを意味する場合でも飛び飛びの複数セル（範囲）であることがあり得る。
ActiveCell・・・そのままアクティブなセル。単一セルであり複数（またはセル範囲）になることはない
という感じになります。
このときに注意すべきなのは、飛び飛びのセル（範囲）の場合、コピーできる（場合もある）が、飛び飛びのセル（範囲）へ貼付はできないというところです。
以下のコードをステップ実行していただければ、言わんとしていることは伝わると思います。
Sub 実験01()
Stop
On Error GoTo エラー表示
Range("B1:C2,C4").Copy '←失敗する例１
With Range("B1:B2,B4")
.Copy
.Offset(, 1).PasteSpecial Paste:=xlPasteValues ' ←失敗する例２
.Areas(1).Cells(1, 1).Offset(, 1).PasteSpecial Paste:=xlPasteValues ' ←エラーにならないが結果は・・・
MsgBox .Offset(, 1).Address(0, 0) & "ではなく、" & vbLf & Selection.Address(0, 0) & "に貼付しました"
End With
Exit Sub
エラー表示:
MsgBox "エラーが発生しました" & vbLf & vbLf & "エラー番号：" & Err.Number & vbLf & Err.Description
Err.Clear
Resume Next
End Sub
■３
したがって、仰る「2箇所同時」というのが、飛び飛びの２か所（以上）を同時に変更した場合のことを言っているのであれば、[[20240727134719]]で学習されたように、ループ処理で１セル（範囲）ごとに処理する必要があります。
（今回は違うようですが）
■４
余談になりますが↓の記述も適切とは思えません。
ActiveCell.Offset(0, 32).Range("B1").Select
~~~~~~~~~~~~
エクセル君の忖度により何とかなっちゃっていますが↓のように解釈されています。
ActiveCell.Offset(0, 32).Cells(1, 2).Select
別に間違いではないですが、それなら素直に↓のように書くべきでしょう。
ActiveCell.Offset(0, 33).Select
また、ExcelVBAでは基本的にシートやセルなど（オブジェクトと言います）は、きちんと明示すればいちいちアクティブにしたり選択したりする必要はありませんし、可読性向上の観点からもActive○○やSelection.○○に依存するような書き方はお勧めしません。（好みの問題ではありますが）
■５
上記を踏まえると、以下のようなコードでも解決できたとおもいます。
興味があればステップ実行等により、研究してみてください。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim bufRNG As Range, MyRNG As Range
Set bufRNG = Intersect(Target, Me.Range("B1:B12150"))
If Not bufRNG Is Nothing Then
For Each MyRNG In bufRNG.Areas
MyRNG.Copy
Intersect(MyRNG.EntireRow, Me.Range("AI:AI,AQ:AQ")).PasteSpecial Paste:=xlPasteValues
Next MyRNG
Application.CutCopyMode = False
Intersect(bufRNG.EntireRow, Me.Range("AI:AI,AQ:AQ")).Interior.Color = 255
End If
End Sub
※上記のコードは研究材料としての提供であり、完成品プレゼントの意図はありません。 ちゃんと理解して頂きたいので丸パクリして完成！というのはご遠慮ください。 (ご自身のコードを修正していって、結果が同じになってしまっただけならOKです)
■６
ちなみに、上記の処理だとAI,AQ列の塗りつぶしはいったん塗りつぶししたらそのままになります。
もしも、B列の値がクリアされたら（""になったら）塗りつぶしを解除したいということなら↓のように１セル（行）ごとに判定する必要があります。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim bufRNG As Range, MyRNG As Range
Set bufRNG = Intersect(Target, Me.Range("B1:B12150"))
If Not bufRNG Is Nothing Then
Application.ScreenUpdating = False
For Each MyRNG In bufRNG '←１セルずつに変更
With Intersect(MyRNG.EntireRow, Me.Range("AI1,AQ1").EntireColumn)
'↓値が「""」かどうかで処理分岐
If MyRNG.Value <> "" Then
MyRNG.Copy
.PasteSpecial Paste:=xlPasteValues
.Interior.Color = 255
Else
.Clear
End If
End With
Next MyRNG
Application.CutCopyMode = False
Application.ScreenUpdating = True
End If
End Sub
（もこな２ ） 2024/08/01(木) 19:13:01
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.