web-dev-qa-db-ja.com

セルが数式によって値を変更するたびにVBAコードを実行するにはどうすればよいですか？

セルが数式によって値を変更するたびにVBAコードを実行する方法を知りたいですか？セルの値がユーザーによって変更されたときにコードを実行できましたが、機能しませんw

excelvbaformula
7
Cloaky

セルA1に数式があり（例：= B1 * C1）、セルB1またはC1のいずれかが更新されてA1が変更されるたびに、VBAコードを実行したい場合は、次を使用できます。

Private Sub Worksheet_Calculate()
    Dim target As Range
    Set target = Range("A1")

    If Not Intersect(target, Range("A1")) Is Nothing Then
    //Run my VBA code
    End If
End Sub

更新

私の知る限り、Worksheet_Calculateの問題は、スプレッドシート上の数式を含むすべてのセルに対して起動し、どのセルが再計算されたかを判別できないことです（つまり、Worksheet_CalculateはTargetオブジェクトを提供しません）

これを回避するために、列Aに多数の数式があり、どの数式が更新されたかを識別してその特定のセルにコメントを追加する場合は、次のコードでそれを実現できると思います。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim updatedCell As Range
    Set updatedCell = Range(Target.Dependents.Address)

    If Not Intersect(updatedCell, Range("A:A")) Is Nothing Then
       updatedCell.AddComment ("My Comments")
    End If

End Sub

説明すると、数式を更新するには、その数式への入力セルの1つを変更する必要があります。 A1の式が=B1 * C1の場合、A1を更新するには、B1またはC1のいずれかを変更する必要があります。

Worksheet_Changeイベントを使用してs/sheetのセルの変更を検出し、Excelの監査機能を使用して依存関係を追跡できます。セルA1はB1とC1の両方に依存しており、この場合、コードTarget.Dependents.Addressは$A$1またはB1への変更に対してC1を返します。

これを前提として、次に行う必要があるのは、依存アドレスが列Aにあるかどうかを確認することだけです（Intersectを使用）。列Aにある場合は、適切なセルにコメントを追加できます。

これは、コメントをセルに1回だけ追加する場合にのみ機能することに注意してください。同じセル内のコメントを引き続き上書きする場合は、コードを変更してコメントの存在を確認してから、必要に応じて削除する必要があります。

13
Alex P

使用したコードは機能しません。これは、セルの変更が数式を含むセルではなく、セルが変更されているためです:)

ワークシートのモジュールに追加する必要があるものは次のとおりです。

（日付：「SetrDependents = Target.Dependents」という行は、依存関係がない場合にエラーを発生させます。この更新により、これが処理されます。）

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rDependents As Range

    On Error Resume Next
    Set rDependents = Target.Dependents
    If Err.Number > 0 Then
        Exit Sub
    End If
    ' If the cell with the formula is "F160", for example...
    If Not Application.Intersect(rDependents, Range("F160")) Is Nothing Then
        Call abc
    End If
End Sub

Private Sub abc()
    MsgBox """abc()"" is running now"
End Sub

問題のセルアドレスの配列を設定することにより、依存セルが多数ある場合にこれを拡張できます。次に、配列内の各アドレスをテストし（これには任意のループ構造を使用できます）、変更されたセルに対応するdesitedサブルーチンを実行します（SELECT CASE ...を使用）。

2
Gene Skuratovsky

これがクラスを使用する別の方法です。クラスはセルの初期値とセルアドレスを格納できます。計算イベントでは、アドレスの現在の値を保存されている初期値と比較します。以下の例は、1つのセル（「A2」）のみをリッスンするように作成されていますが、モジュール内のより多くのセルのリッスンを開始するか、より広い範囲で機能するようにクラスを変更できます。

「Class1」と呼ばれるクラスモジュール：

Public WithEvents MySheet As Worksheet
Public MyRange As Range
Public MyIniVal As Variant

Public Sub Initialize_MySheet(Sh As Worksheet, Ran As Range)
    Set MySheet = Sh
    Set MyRange = Ran
    MyIniVal = Ran.Value
End Sub
Private Sub MySheet_Calculate()

If MyRange.Value <> MyIniVal Then
    Debug.Print MyRange.Address & " was changed from " & MyIniVal & " to " & MyRange.Value
    StartClass
End If

End Sub

Normallモジュールでクラスを初期化します。

Dim MyClass As Class1

Sub StartClass()
Set MyClass = Nothing
Set MyClass = New Class1
MyClass.Initialize_MySheet ActiveSheet, Range("A2")
End Sub
1
Radek

これが私のコードです：

私はそれがひどいように見えることを知っています、しかしそれは働きます！もちろん、はるかに優れたソリューションもあります。

コードの説明：

ワークブックが開くと、セルB15からN15までの値が、変数PrevValbからPrevValnまでに保存されます。 Worksheet_Calculate（）イベントが発生すると、前の値がセルの実際の値と比較されます。値に変化がある場合、セルは赤色でマークされます。このコードは関数を使って書くことができるので、彼ははるかに短くて読みやすくなっています。色を前の色にリセットするcolor-reset-button（Seenchanges）があります。

ワークブック：

Private Sub Workbook_Open()
PrevValb = Tabelle1.Range("B15").Value
PrevValc = Tabelle1.Range("C15").Value
PrevVald = Tabelle1.Range("D15").Value
PrevVale = Tabelle1.Range("E15").Value
PrevValf = Tabelle1.Range("F15").Value
PrevValg = Tabelle1.Range("G15").Value
PrevValh = Tabelle1.Range("H15").Value
PrevVali = Tabelle1.Range("I15").Value
PrevValj = Tabelle1.Range("J15").Value
PrevValk = Tabelle1.Range("K15").Value
PrevVall = Tabelle1.Range("L15").Value
PrevValm = Tabelle1.Range("M15").Value
PrevValn = Tabelle1.Range("N15").Value
End Sub

モジュール：

Sub Seenchanges_Klicken()
Range("B15:N15").Interior.Color = RGB(252, 213, 180)
End Sub

Sheet1：

Private Sub Worksheet_Calculate()
If Range("B15").Value <> PrevValb Then
    Range("B15").Interior.Color = RGB(255, 0, 0)
    PrevValb = Range("B15").Value
End If
If Range("C15").Value <> PrevValc Then
    Range("C15").Interior.Color = RGB(255, 0, 0)
    PrevValc = Range("C15").Value
End If
If Range("D15").Value <> PrevVald Then
    Range("D15").Interior.Color = RGB(255, 0, 0)
    PrevVald = Range("D15").Value
End If
If Range("E15").Value <> PrevVale Then
    Range("E15").Interior.Color = RGB(255, 0, 0)
    PrevVale = Range("E15").Value
End If
If Range("F15").Value <> PrevValf Then
    Range("F15").Interior.Color = RGB(255, 0, 0)
    PrevValf = Range("F15").Value
End If
If Range("G15").Value <> PrevValg Then
    Range("G15").Interior.Color = RGB(255, 0, 0)
    PrevValg = Range("G15").Value
End If
If Range("H15").Value <> PrevValh Then
    Range("H15").Interior.Color = RGB(255, 0, 0)
    PrevValh = Range("H15").Value
End If
If Range("I15").Value <> PrevVali Then
    Range("I15").Interior.Color = RGB(255, 0, 0)
    PrevVali = Range("I15").Value
End If
If Range("J15").Value <> PrevValj Then
    Range("J15").Interior.Color = RGB(255, 0, 0)
    PrevValj = Range("J15").Value
End If
If Range("K15").Value <> PrevValk Then
    Range("K15").Interior.Color = RGB(255, 0, 0)
    PrevValk = Range("K15").Value
End If
If Range("L15").Value <> PrevVall Then
    Range("L15").Interior.Color = RGB(255, 0, 0)
    PrevVall = Range("L15").Value
End If
If Range("M15").Value <> PrevValm Then
    Range("M15").Interior.Color = RGB(255, 0, 0)
    PrevValm = Range("M15").Value
End If
If Range("N15").Value <> PrevValn Then
    Range("N15").Interior.Color = RGB(255, 0, 0)
    PrevValn = Range("N15").Value
End If
End Sub
0
Adrian__