macros在RTD更新上运行

我的问题如下：

我正在运行一个实时数据服务器倒数从900到0.一旦倒计数达到5，我希望excel复制工作表（RTD_NEWS）范围（B2到B61），并将其作为值粘贴到一个新的工作表。

问题是我的macros将不会自动做到这一点，当时间保持命中5.如果我击中运行时单元格是5它正确运行。

我做了2个macros，其中第一个需要运行做我想要的，第二个工程，如果我手动更改单元格，但不与RTD链接。

第一个macros是：

Function Test() Dim TimeRemaining As Long TimeRemaining = ActiveWorkbook.Sheets("RTD_NEWS").Range("D2") If TimeRemaining = 5 Then Application.Goto ActiveWorkbook.Sheets("RTD_NEWS").Range("B2", "B61") Selection.Copy Worksheets.Add Application.Goto ActiveSheet.Range("B21") ActiveCell.PasteSpecial (xlPasteValues) Application.Wait Now + TimeValue("00:00:06") End If End Function 

第二个macros是：

 Sub auto_open() ' Run the macro DidCellsChange any time a entry is made in a ' cell in Sheet1. ThisWorkbook.Worksheets("RTD_NEWS").OnEntry = "DidCellsChange" End Sub Sub DidCellsChange() Dim KeyCells As String ' Define which cells should trigger the KeyCellsChanged macro. KeyCells = "D2" ' If the Activecell is one of the key cells, call the ' KeyCellsChanged macro. If Not Application.Intersect(ActiveCell, Range(KeyCells)) _ Is Nothing Then KeyCellsChanged End Sub Sub KeyCellsChanged() Dim Cell As Object For Each Cell In ActiveWorkbook.Sheets("RTD_NEWS").Range("D2") If Cell = "200" Then Application.Goto ActiveWorkbook.Sheets("RTD_NEWS").Range("B2", "B61") Selection.Copy Worksheets.Add Application.Goto ActiveSheet.Range("B21") ActiveCell.PasteSpecial (xlPasteValues) Application.Wait Now + TimeValue("00:00:06") End If Next Cell End Sub