本当に変化したときだけChangeイベントを起こす(Excel)

本当に値が変更されたときだけChangeイベントを起こす

標題はちょっと嘘。

結果的に値が変わったときだけ処理をする、というもの。

作戦

次のような作戦を考えた。

複数セルの値が変更された場合の処理は、現状力不足ゆえ諦めている。

複数セルの値が変更されたときは、変更前に戻すようにする。

• ブックオープン時に、シートの特定の範囲の値を2次元配列にぶち込む。
• Changeイベントが起こったときに、Target.Valueを2次元配列に格納されている値と比較する。
• 同じ値だったらそのままExit。
• 異なる値だったら必要な処理を行う。

まあ、こんな感じ。

準備

今回は単なる実験なので、シート上に

このように３×３の領域を用意して、それぞれに色々な値（笑）を入れておく。

んで、この範囲に「ListArea」と名前を付けておく。

後はコードを書くだけ。

コード

シートモジュール Sh01

Option Explicit

Private Const LIST_AREA As String = "ListArea"

Private listValues As Variant

Public Property Get ListArea() As Range
  Set ListArea = Me.Range(LIST_AREA)
End Property

Public Property Get ListLeftTop() As Range
  Dim rng As Range
  Set rng = Me.ListArea.Cells(1, 1)
  Set ListLeftTop = rng
End Property

Public Property Get ListRightBottom() As Range
  Dim rng As Range
  With Me.ListArea
    Set rng = .Cells(.Rows.Count, Columns.Count)
  End With
  Set ListRightBottom = rng
End Property

Private Sub Worksheet_Change(ByVal Target As Range)
  '複数セルが変更されたときは、値を元に戻してExit'
  Application.EnableEvents = False
  If Target.Count > 1 Then _
    Me.ListArea.Value = listValues: GoTo Finalizer
  'Targetがリスト外だったらExit'
  If Not isWithinList(Target) Then GoTo Finalizer
  '変更されたかどうかを判定'
  Dim r As Long, c As Long
  r = getRelativeRow(Target)
  c = getRelativeColumn(Target)
  '結果的に変更がなかったときはExit'
  If Target.Value = listValues(r, c) Then GoTo Finalizer
  '変更があった場合は何らかの処理をする'
  Call MsgBox("Value has been changed...")
  'リストの値を再配列化'
  Call setListValues
Finalizer:
  Application.EnableEvents = True
End Sub

Private Function isWithinList( _
             ByVal tgtcell As Range) As Boolean
  isWithinList = False
  'リストの外側だったらFalseを返す'
  With tgtcell
    If .Row < Me.ListLeftTop.Row Or _
       .Row > Me.ListRightBottom.Row Then Exit Function
    If .Column < Me.ListLeftTop.Column Or _
       .Column > Me.ListRightBottom.Column Then Exit Function
  End With
  'リスト内部だったらTrueを返す'
  isWithinList = True
End Function

'リスト内での相対位置を割り出す'
Private Function getRelativeRow( _
             ByVal tgtcell As Range) As Long
  Dim ret As Long
  ret = tgtcell.Row - Me.ListLeftTop.Row + 1
  getRelativeRow = ret
End Function
Private Function getRelativeColumn( _
             ByVal tgtcell As Range) As Long
  Dim ret As Long
  ret = tgtcell.Column - Me.ListLeftTop.Column + 1
  getRelativeColumn = ret
End Function

'セルの値を2次元配列に突っ込む'
Public Sub setListValues()
  listValues = Me.ListArea.Value
End Sub

ThisWorkbookモジュール

Option Explicit

Private Sub Workbook_Open()
  Call Sh01.setListValues
End Sub

細かい説明は省略ｗ　コード内のコメントを読んでくだされ。

ご質問はコメント欄とかノンプロ研SlackとかTwitterでどうぞ。

使ってみる

こんなふうに動くのだ。

おわりに

動作確認はテキトーなので、使い方によっては実行時エラーが出るかも知れません。

「こんなふうにしたらエラーになるがな！」みたいなのも教えてくださいましたら、気が向いたら対応いたしまする。