2

我对 VBA 很陌生，会尽力解释我的问题。我有一个工作簿，可以将任务列表与 Outlook 任务双向同步，并且工作得很好。我还有一个宏，可以在每次“状态”列（D 列）更改时创建一个静态时间戳。问题是，每次我打开工作表并与 Outlook 同步时，它都会刷新 D 列（以及工作表的其余部分），并且即使状态文本保持不变，时间戳也会更新。下面是我用来创建时间戳的宏：有没有办法修改，所以只有当单元格（D 列）中的实际文本发生变化（即“进行中”变为“等待”）时，它才会时间戳，并且不只是在工作簿同步和刷新所有数据时？

太感谢了！！！修改后的代码--这是从“Microsoft Excel 对象”文件夹中的“ThisWorkbook”与 Outlook 同步的代码。

'--> Declare some constants
'Edit the constants below as needed so they correctly reflect the column number they appear in in the spreadsheet'
Const EXC_CLIENT = 1
Const EXC_SUBJECT = 2
Const EXC_START = 5
Const EXC_STATUS = 4
Const EXC_DUE = 8
Const EXC_EID = 26
Const PROC_NAME = "Outlook Synchronization"
'Do not change any constants from this point on
Const olTaskNotStarted = 0
Const olTaskInProgress = 1
Const olTaskComplete = 2
Const olTaskWaiting = 3
Const olTaskDeferred = 4
Const olText = 1
Const olYesNo = 6
Const olFolderTasks = 13
Const DESKTOP_READOBJECTS = &H1&

'--> Declare some variables
Dim olkApp As Object, _
    olkSes As Object, _
    olkFld As Object, _
    olkTsk As Object, _
    olkPrp As Object, _
    excWks As Excel.Worksheet, _
    lngRow As Long, _
    strRun As String, _
    bolSkp As Boolean

Private Sub InitializeExcel()
    Set excWks = Application.ActiveWorkbook.Sheets(1)
    lngRow = 2
    strRun = Format(Now, "yyyy-mm-dd-hh-nn-ss")
End Sub

Private Sub DeactivateExcel()
    Set excWks = Nothing
End Sub

Private Sub InitializeOutlook()
    Set olkApp = CreateObject("Outlook.Application")
    Set olkSes = olkApp.GetNamespace("MAPI")
    olkSes.Logon olkApp.DefaultProfileName
    Set olkFld = olkSes.GetDefaultFolder(olFolderTasks)
End Sub

Private Sub DeactivateOutlook()
    olkSes.Logoff
    Set olkFld = Nothing
    Set olkSes = Nothing
    Set olkApp = Nothing
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    '--> On saving the workbook you will be given an opportunity to synchronize from Excel to Outlook
    InitializeExcel     'Prep Excel for a sync
    InitializeOutlook   'Prep Outlook for a sync
    Excel2Outlook       'Sync from Excel to Outlook
    DeactivateExcel     'Clean-up Excel
    DeactivateOutlook   'Clean-up Outlook
End Sub

Private Sub Workbook_Open()
    '--> On opening the workbook you will be given an opportunity to syncronize data from Outlook to Excel
    bolSkp = False      'Set this to True if you don't want to be prompted to run the sync when opening/closing the spreadsheet.
    InitializeExcel     'Prep Excel for a sync
    InitializeOutlook   'Prep Outlook for a sync
    Outlook2Excel       'Sync from Outlook to Excel
    DeactivateExcel     'Clean-up Excel
    DeactivateOutlook   'Clean-up Outlook
End Sub

Private Sub Excel2Outlook()
    If Not bolSkp Then
        If MsgBox("Should I sync the tasks to Outlook?", vbQuestion + vbYesNo, PROC_NAME) = vbYes Then
            Do Until excWks.Cells(lngRow, 1) = ""
                Select Case excWks.Cells(lngRow, EXC_EID)
                    Case ""
                        Set olkTsk = olkFld.Items.Add()
                        With olkTsk
                            .UserProperties.Add "ExcelTaskList", olYesNo, True
                            .UserProperties.Item("ExcelTaskList").Value = True
                            .UserProperties.Add "Synced", olText
                            .UserProperties.Item("Synced").Value = strRun
                            .Save
                        End With
                        excWks.Cells(lngRow, EXC_EID) = olkTsk.EntryID
                    Case Else
                        Set olkTsk = olkSes.GetItemFromID(excWks.Cells(lngRow, EXC_EID))
                End Select
                With olkTsk
                    .Subject = excWks.Cells(lngRow, EXC_CLIENT) & "/" & excWks.Cells(lngRow, EXC_SUBJECT)
                    If IsDate(excWks.Cells(lngRow, EXC_START)) Then .StartDate = excWks.Cells(lngRow, EXC_START)
                    If IsDate(excWks.Cells(lngRow, EXC_DUE)) Then .DueDate = excWks.Cells(lngRow, EXC_DUE)
                    Select Case excWks.Cells(lngRow, EXC_STATUS)
                        Case "Complete"
                            .Status = olTaskComplete
                        Case "Deferred"
                            .Status = olTaskDeferred
                        Case "In Progress"
                            .Status = olTaskInProgress
                        Case "Not Started"
                            .Status = olTaskNotStarted
                        Case "Waiting"
                            .Status = olTaskWaiting
                    End Select
                    olkTsk.UserProperties.Item("Synced").Value = strRun
                    .Save
                End With
                lngRow = lngRow + 1
            Loop
            For lngRow = olkFld.Items.Count To 1 Step -1
                Set olkTsk = olkFld.Items(lngRow)
                Set olkPrp = olkTsk.UserProperties.Find("ExcelTaskList", True)
                If TypeName(olkPrp) <> "Nothing" Then
                    If olkTsk.UserProperties.Item("Synced").Value < strRun Then
                        olkTsk.Delete
                    End If
                End If
            Next
        End If
    End If
End Sub

Private Sub Outlook2Excel()
    Dim excRng As Excel.Range, arrTmp As Variant, intCnt As Integer
    If Not bolSkp Then
        If MsgBox("Should I sync tasks from Outlook?", vbQuestion + vbYesNo, PROC_NAME) = vbYes Then
            For intCnt = olkFld.Items.Count To 1 Step -1
                Set olkTsk = olkFld.Items(intCnt)
                Set olkPrp = olkTsk.UserProperties.Find("ExcelTaskList", True)
                If TypeName(olkPrp) = "Nothing" Then
                    'The task does not exist in the spreadsheet.  Add it.
                    lngRow = excWks.UsedRange.Rows.Count + 1
                    With olkTsk
                        If InStr(1, .Subject, "/") > 0 Then
                            arrTmp = Split(.Subject, "/")
                            excWks.Cells(lngRow, EXC_CLIENT) = arrTmp(0)
                            excWks.Cells(lngRow, EXC_SUBJECT) = arrTmp(1)
                        Else
                            excWks.Cells(lngRow, EXC_CLIENT) = "Select Client"
                            excWks.Cells(lngRow, EXC_SUBJECT) = .Subject
                        End If
                        If .StartDate <> #1/1/4501# Then
                            excWks.Cells(lngRow, EXC_START) = .StartDate
                            excWks.Cells(lngRow, EXC_START).NumberFormat = "[$-409]d-mmm;@"
                        End If
                        Select Case .Status
                            Case olTaskComplete
                                excWks.Cells(lngRow, EXC_STATUS) = "Complete"
                            Case olTaskDeferred
                                excWks.Cells(lngRow, EXC_STATUS) = "Deferred"
                            Case olTaskInProgress
                                excWks.Cells(lngRow, EXC_STATUS) = "In Progress"
                            Case olTaskNotStarted
                                excWks.Cells(lngRow, EXC_STATUS) = "Not Started"
                            Case olTaskWaiting
                                excWks.Cells(lngRow, EXC_STATUS) = "Waiting"
                        End Select
                        If .DueDate <> #1/1/4501# Then
                            excWks.Cells(lngRow, EXC_DUE) = .DueDate
                            excWks.Cells(lngRow, EXC_DUE).NumberFormat = "[$-409]ddd, mmm. d;@"
                        End If
                        excWks.Cells(lngRow, EXC_EID) = .EntryID
                        .UserProperties.Add "ExcelTaskList", olYesNo, True
                        .UserProperties.Item("ExcelTaskList").Value = True
                        .UserProperties.Add "Synced", olText
                        .UserProperties.Item("Synced").Value = strRun
                        .Save
                    End With
                Else
                    If olkTsk.UserProperties.Item("Synced").Value > olkTsk.LastModificationTime Then
                        For lngRow = 2 To excWks.UsedRange.Rows.Count
                            If excWks.Cells(lngRow, EXC_EID) = olkTsk.EntryID Then Exit For
                        Next
                        If lngRow >= 2 And lngRow <= excWks.UsedRange.Rows.Count Then
                            With olkTsk
                                If InStr(1, .Subject, "/") > 0 Then
                                    arrTmp = Split(.Subject, "/")
                                    excWks.Cells(lngRow, EXC_CLIENT) = arrTmp(0)
                                    excWks.Cells(lngRow, EXC_SUBJECT) = arrTmp(1)
                                Else
                                    excWks.Cells(lngRow, EXC_CLIENT) = "Select Client"
                                    excWks.Cells(lngRow, EXC_SUBJECT) = .Subject
                                End If
                                If .StartDate <> #1/1/4501# Then excWks.Cells(lngRow, EXC_START) = .StartDate
                                Select Case .Status
                                    Case olTaskComplete
                                        excWks.Cells(lngRow, EXC_STATUS) = "Complete"
                                    Case olTaskDeferred
                                        excWks.Cells(lngRow, EXC_STATUS) = "Deferred"
                                    Case olTaskInProgress
                                        excWks.Cells(lngRow, EXC_STATUS) = "In Progress"
                                    Case olTaskNotStarted
                                        excWks.Cells(lngRow, EXC_STATUS) = "Not Started"
                                    Case olTaskWaiting
                                        excWks.Cells(lngRow, EXC_STATUS) = "Waiting"
                                End Select
                                If .DueDate <> #1/1/4501# Then excWks.Cells(lngRow, EXC_DUE) = .DueDate
                                .UserProperties.Item("Synced").Value = strRun
                                .Save
                            End With
                        Else
                            MsgBox "Critical problem.  There was no match in the spreadsheet for the task" & vbCrLf & vbTab & olkTsk.Subject, vbCritical + vbOKOnly, PROC_NAME
                        End If
                    End If
                End If
            Next
            On Error Resume Next
            For lngRow = excWks.UsedRange.Rows.Count To 2 Step -1
                If excWks.Cells(lngRow, EXC_EID) <> "" Then
                    Set olkTsk = olkSes.GetItemFromID(excWks.Cells(lngRow, EXC_EID))
                    Debug.Print excWks.Cells(lngRow, EXC_SUBJECT)
                    If (TypeName(olkTsk) = "Nothing") Or (olkTsk.Parent.Name = "Deleted Items") Then
                        Set excRng = excWks.Range("A" & lngRow, "Z" & lngRow)
                        excRng.Delete xlShiftUp
                    End If
                End If
                Set olkTsk = Nothing
            Next
            On Error GoTo 0
        End If
    End If
End Sub

Public Sub ForceExcel2Close()
    Dim varDesktop As Variant
    varDesktop = OpenInputDesktop(0, False, DESKTOP_READOBJECTS)
    'varDesktop will be 0 if the screen is locked, non-zero if it is not.
    If varDesktop = 0 Then
        bolSkp = True
        ThisWorkbook.Save
        CreateScriptFile
        RunScriptFile
    End If
End Sub

Sub CreateScriptFile()
    Dim objFSO As Object, objFil As Object
    Set objFSO = CreateObject("Scripting.FileSystemobject")
    Set objFil = objFSO.CreateTextFile(Environ("TMP") & "\CloseExcel.vbs", True)
    With objFil
        .WriteLine "WScript.Sleep 5000"
        .WriteLine "Set excApp = GetObject(,""Excel.Application"")"
        .WriteLine "excApp.Quit"
        .WriteLine "Set excApp = Nothing"
        .Close
    End With
    Set objFSO = Nothing
    Set objFil = Nothing
End Sub

Sub RunScriptFile()
    Dim objShl As Object
    Set objShl = CreateObject("WScript.Shell")
    objShl.Run Environ("TMP") & "\CloseExcel.vbs", 0, False
    Set objShl = Nothing
End Sub
4

1 回答 1

1

以下代码实现了我在评论中谈到的想法：

保留一份您认为“未更改”的数据副本，当 SheetChange事件触发时，将实际的新值与参考值进行比较。如果两个值不相同，请执行您想要执行的操作。

已编辑基于不适合您的代码的第一个版本，我怀疑刷新发生在 workbook_open 事件触发之前。为了解决这个问题，我创建了一个新的变体 ，initialized它最初将是empty（没有分配给它的值）。当SheetChange事件触发时，它检查这个变量的状态：如果它是空的，它知道colStore在运行其余代码之前进行初始化。那应该可以解决问题。否则这个宏的工作方式是不变的：

通过在内存中“在我们弄乱它之前”保留数据的副本，如果值实际上没有改变，您可以防止时间戳的“更新”。

它适用于一个简单的测试用例 - 当我“编辑”一个单元格但放回相同的值时，会触发“更改”事件，但不会更新日期戳。

让我知道这是否需要进一步解释。

Option Explicit
Dim colStore
Dim initialized
Const colOfInterest = "D2:D1000" ' make this the column you want to be active on
Dim rowOne As Integer

Private Sub Workbook_Open()
  If IsEmpty(initialized) Then
    MsgBox "opening workbook. Nothing has been initialized yet"
    initializeIt
  End If
End Sub

Private Sub initializeIt()
  colStore = Range(colOfInterest).Value
  rowOne = Range(colOfInterest).Cells(1).Row
  initialized = True
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim tempAddress
On Error GoTo leaveSub

If IsEmpty(initialized) Then
  MsgBox "fired sheet_change before workbook_open!"
  initializeIt
End If

With Target
        If .Count > 1 Then Exit Sub
        If Not Intersect(Range(colOfInterest), .Cells) Is Nothing Then
            Application.EnableEvents = False
            If IsEmpty(.Value) Then
                .Offset(0, 2).ClearContents
            Else
                ' see if value actually changed
                tempAddress = .Row
                If .Value = colStore(.Row - rowOne + 1, 1) Then
                Else
                  colStore(.Row - rowOne + 1, 1) = .Value ' update the store
                  ' update the date:
                  With .Offset(0, 2)
                    .NumberFormat = "mmm, d, h:mm:ss AM/PM"
                    .Value = Now
                  End With
                End If
            End If
        End If
    End With
leaveSub:
  Application.EnableEvents = True

End Sub

第二次编辑根据您给出的代码，我认为以下“代码合并”应该会产生一些有效的东西。我无法对其进行测试 - 但请告诉我这是否适合您，或者您是否仍有问题。这里有一些 TEST MESSAGEs - 在一切正常后将它们取出（它们只是帮助确认程序流程是正确的）。将所有这些代码放在 Workbook 模块中：

Option Explicit
Dim colStore
Dim initialized
Const colOfInterest = "D2:D1000" ' make this the column you want to be active on
Dim rowOne As Integer

'--> Declare some constants
'Edit the constants below as needed so they correctly reflect the column number they appear in in the spreadsheet'
Const EXC_CLIENT = 1
Const EXC_SUBJECT = 2
Const EXC_START = 5
Const EXC_STATUS = 4
Const EXC_DUE = 8
Const EXC_EID = 26
Const PROC_NAME = "Outlook Synchronization"
'Do not change any constants from this point on
Const olTaskNotStarted = 0
Const olTaskInProgress = 1
Const olTaskComplete = 2
Const olTaskWaiting = 3
Const olTaskDeferred = 4
Const olText = 1
Const olYesNo = 6
Const olFolderTasks = 13
Const DESKTOP_READOBJECTS = &H1&

'--> Declare some variables
Dim olkApp As Object, _
    olkSes As Object, _
    olkFld As Object, _
    olkTsk As Object, _
    olkPrp As Object, _
    excWks As Excel.Worksheet, _
    lngRow As Long, _
    strRun As String, _
    bolSkp As Boolean

Private Sub InitializeExcel()
    Set excWks = Application.ActiveWorkbook.Sheets(1)
    lngRow = 2
    strRun = Format(Now, "yyyy-mm-dd-hh-nn-ss")
End Sub

Private Sub DeactivateExcel()
    Set excWks = Nothing
End Sub

Private Sub InitializeOutlook()
    Set olkApp = CreateObject("Outlook.Application")
    Set olkSes = olkApp.GetNamespace("MAPI")
    olkSes.Logon olkApp.DefaultProfileName
    Set olkFld = olkSes.GetDefaultFolder(olFolderTasks)
End Sub

Private Sub DeactivateOutlook()
    olkSes.Logoff
    Set olkFld = Nothing
    Set olkSes = Nothing
    Set olkApp = Nothing
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    '--> On saving the workbook you will be given an opportunity to synchronize from Excel to Outlook
    InitializeExcel     'Prep Excel for a sync
    InitializeOutlook   'Prep Outlook for a sync
    Excel2Outlook       'Sync from Excel to Outlook
    DeactivateExcel     'Clean-up Excel
    DeactivateOutlook   'Clean-up Outlook
End Sub

Private Sub Workbook_Open()
'--> Adding a few lines of code to capture the "current status"
'--> before anything gets updated / refreshed
If IsEmpty(initialized) Then
    MsgBox "TEST MESSAGE. Opening workbook. Nothing has been initialized yet."
    initializeIt
  End If
'--> On opening the workbook you will be given an opportunity to syncronize data from Outlook to Excel
    bolSkp = False      'Set this to True if you don't want to be prompted to run the sync when opening/closing the spreadsheet.
    InitializeExcel     'Prep Excel for a sync
    InitializeOutlook   'Prep Outlook for a sync
    Outlook2Excel       'Sync from Outlook to Excel
    DeactivateExcel     'Clean-up Excel
    DeactivateOutlook   'Clean-up Outlook
End Sub

Private Sub Excel2Outlook()
    If Not bolSkp Then
        If MsgBox("Should I sync the tasks to Outlook?", vbQuestion + vbYesNo, PROC_NAME) = vbYes Then
            Do Until excWks.Cells(lngRow, 1) = ""
                Select Case excWks.Cells(lngRow, EXC_EID)
                    Case ""
                        Set olkTsk = olkFld.Items.Add()
                        With olkTsk
                            .UserProperties.Add "ExcelTaskList", olYesNo, True
                            .UserProperties.Item("ExcelTaskList").Value = True
                            .UserProperties.Add "Synced", olText
                            .UserProperties.Item("Synced").Value = strRun
                            .Save
                        End With
                        excWks.Cells(lngRow, EXC_EID) = olkTsk.EntryID
                    Case Else
                        Set olkTsk = olkSes.GetItemFromID(excWks.Cells(lngRow, EXC_EID))
                End Select
                With olkTsk
                    .Subject = excWks.Cells(lngRow, EXC_CLIENT) & "/" & excWks.Cells(lngRow, EXC_SUBJECT)
                    If IsDate(excWks.Cells(lngRow, EXC_START)) Then .StartDate = excWks.Cells(lngRow, EXC_START)
                    If IsDate(excWks.Cells(lngRow, EXC_DUE)) Then .DueDate = excWks.Cells(lngRow, EXC_DUE)
                    Select Case excWks.Cells(lngRow, EXC_STATUS)
                        Case "Complete"
                            .Status = olTaskComplete
                        Case "Deferred"
                            .Status = olTaskDeferred
                        Case "In Progress"
                            .Status = olTaskInProgress
                        Case "Not Started"
                            .Status = olTaskNotStarted
                        Case "Waiting"
                            .Status = olTaskWaiting
                    End Select
                    olkTsk.UserProperties.Item("Synced").Value = strRun
                    .Save
                End With
                lngRow = lngRow + 1
            Loop
            For lngRow = olkFld.Items.Count To 1 Step -1
                Set olkTsk = olkFld.Items(lngRow)
                Set olkPrp = olkTsk.UserProperties.Find("ExcelTaskList", True)
                If TypeName(olkPrp) <> "Nothing" Then
                    If olkTsk.UserProperties.Item("Synced").Value < strRun Then
                        olkTsk.Delete
                    End If
                End If
            Next
        End If
    End If
End Sub

Private Sub Outlook2Excel()
    Dim excRng As Excel.Range, arrTmp As Variant, intCnt As Integer
    If Not bolSkp Then
        If MsgBox("Should I sync tasks from Outlook?", vbQuestion + vbYesNo, PROC_NAME) = vbYes Then
            For intCnt = olkFld.Items.Count To 1 Step -1
                Set olkTsk = olkFld.Items(intCnt)
                Set olkPrp = olkTsk.UserProperties.Find("ExcelTaskList", True)
                If TypeName(olkPrp) = "Nothing" Then
                    'The task does not exist in the spreadsheet.  Add it.
                    lngRow = excWks.UsedRange.Rows.Count + 1
                    With olkTsk
                        If InStr(1, .Subject, "/") > 0 Then
                            arrTmp = Split(.Subject, "/")
                            excWks.Cells(lngRow, EXC_CLIENT) = arrTmp(0)
                            excWks.Cells(lngRow, EXC_SUBJECT) = arrTmp(1)
                        Else
                            excWks.Cells(lngRow, EXC_CLIENT) = "Select Client"
                            excWks.Cells(lngRow, EXC_SUBJECT) = .Subject
                        End If
                        If .StartDate <> #1/1/4501# Then
                            excWks.Cells(lngRow, EXC_START) = .StartDate
                            excWks.Cells(lngRow, EXC_START).NumberFormat = "[$-409]d-mmm;@"
                        End If
                        Select Case .Status
                            Case olTaskComplete
                                excWks.Cells(lngRow, EXC_STATUS) = "Complete"
                            Case olTaskDeferred
                                excWks.Cells(lngRow, EXC_STATUS) = "Deferred"
                            Case olTaskInProgress
                                excWks.Cells(lngRow, EXC_STATUS) = "In Progress"
                            Case olTaskNotStarted
                                excWks.Cells(lngRow, EXC_STATUS) = "Not Started"
                            Case olTaskWaiting
                                excWks.Cells(lngRow, EXC_STATUS) = "Waiting"
                        End Select
                        If .DueDate <> #1/1/4501# Then
                            excWks.Cells(lngRow, EXC_DUE) = .DueDate
                            excWks.Cells(lngRow, EXC_DUE).NumberFormat = "[$-409]ddd, mmm. d;@"
                        End If
                        excWks.Cells(lngRow, EXC_EID) = .EntryID
                        .UserProperties.Add "ExcelTaskList", olYesNo, True
                        .UserProperties.Item("ExcelTaskList").Value = True
                        .UserProperties.Add "Synced", olText
                        .UserProperties.Item("Synced").Value = strRun
                        .Save
                    End With
                Else
                    If olkTsk.UserProperties.Item("Synced").Value > olkTsk.LastModificationTime Then
                        For lngRow = 2 To excWks.UsedRange.Rows.Count
                            If excWks.Cells(lngRow, EXC_EID) = olkTsk.EntryID Then Exit For
                        Next
                        If lngRow >= 2 And lngRow <= excWks.UsedRange.Rows.Count Then
                            With olkTsk
                                If InStr(1, .Subject, "/") > 0 Then
                                    arrTmp = Split(.Subject, "/")
                                    excWks.Cells(lngRow, EXC_CLIENT) = arrTmp(0)
                                    excWks.Cells(lngRow, EXC_SUBJECT) = arrTmp(1)
                                Else
                                    excWks.Cells(lngRow, EXC_CLIENT) = "Select Client"
                                    excWks.Cells(lngRow, EXC_SUBJECT) = .Subject
                                End If
                                If .StartDate <> #1/1/4501# Then excWks.Cells(lngRow, EXC_START) = .StartDate
                                Select Case .Status
                                    Case olTaskComplete
                                        excWks.Cells(lngRow, EXC_STATUS) = "Complete"
                                    Case olTaskDeferred
                                        excWks.Cells(lngRow, EXC_STATUS) = "Deferred"
                                    Case olTaskInProgress
                                        excWks.Cells(lngRow, EXC_STATUS) = "In Progress"
                                    Case olTaskNotStarted
                                        excWks.Cells(lngRow, EXC_STATUS) = "Not Started"
                                    Case olTaskWaiting
                                        excWks.Cells(lngRow, EXC_STATUS) = "Waiting"
                                End Select
                                If .DueDate <> #1/1/4501# Then excWks.Cells(lngRow, EXC_DUE) = .DueDate
                                .UserProperties.Item("Synced").Value = strRun
                                .Save
                            End With
                        Else
                            MsgBox "Critical problem.  There was no match in the spreadsheet for the task" & vbCrLf & vbTab & olkTsk.Subject, vbCritical + vbOKOnly, PROC_NAME
                        End If
                    End If
                End If
            Next
            On Error Resume Next
            For lngRow = excWks.UsedRange.Rows.Count To 2 Step -1
                If excWks.Cells(lngRow, EXC_EID) <> "" Then
                    Set olkTsk = olkSes.GetItemFromID(excWks.Cells(lngRow, EXC_EID))
                    Debug.Print excWks.Cells(lngRow, EXC_SUBJECT)
                    If (TypeName(olkTsk) = "Nothing") Or (olkTsk.Parent.Name = "Deleted Items") Then
                        Set excRng = excWks.Range("A" & lngRow, "Z" & lngRow)
                        excRng.Delete xlShiftUp
                    End If
                End If
                Set olkTsk = Nothing
            Next
            On Error GoTo 0
        End If
    End If
End Sub

Public Sub ForceExcel2Close()
    Dim varDesktop As Variant
    varDesktop = OpenInputDesktop(0, False, DESKTOP_READOBJECTS)
    'varDesktop will be 0 if the screen is locked, non-zero if it is not.
    If varDesktop = 0 Then
        bolSkp = True
        ThisWorkbook.Save
        CreateScriptFile
        RunScriptFile
    End If
End Sub

Sub CreateScriptFile()
    Dim objFSO As Object, objFil As Object
    Set objFSO = CreateObject("Scripting.FileSystemobject")
    Set objFil = objFSO.CreateTextFile(Environ("TMP") & "\CloseExcel.vbs", True)
    With objFil
        .WriteLine "WScript.Sleep 5000"
        .WriteLine "Set excApp = GetObject(,""Excel.Application"")"
        .WriteLine "excApp.Quit"
        .WriteLine "Set excApp = Nothing"
        .Close
    End With
    Set objFSO = Nothing
    Set objFil = Nothing
End Sub

Sub RunScriptFile()
    Dim objShl As Object
    Set objShl = CreateObject("WScript.Shell")
    objShl.Run Environ("TMP") & "\CloseExcel.vbs", 0, False
    Set objShl = Nothing
End Sub

'--> And the other functions (that initialize the data store, and update status
Private Sub initializeIt()
  colStore = Range(colOfInterest).Value
  rowOne = Range(colOfInterest).Cells(1).Row
  initialized = True
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim tempAddress
On Error GoTo leaveSub

If IsEmpty(initialized) Then
  MsgBox "fired sheet_change before workbook_open!"
  initializeIt
End If

With Target
        If .Count > 1 Then Exit Sub
        If Not Intersect(Range(colOfInterest), .Cells) Is Nothing Then
            Application.EnableEvents = False
            If IsEmpty(.Value) Then
                .Offset(0, 2).ClearContents
            Else
                ' see if value actually changed
                tempAddress = .Row
                If .Value = colStore(.Row - rowOne + 1, 1) Then
                Else
                  colStore(.Row - rowOne + 1, 1) = .Value ' update the store
                  ' update the date:
                  With .Offset(0, 2)
                    .NumberFormat = "mmm, d, h:mm:ss AM/PM"
                    .Value = Now
                  End With
                End If
            End If
        End If
    End With
leaveSub:
  Application.EnableEvents = True

End Sub

第三个（也是最后一个？）编辑更新的代码以允许“跟踪”多个列。这是相当普遍的；为了简单起见，我只发布了更改的函数 - 在上面的代码中替换它们，它应该适用于 D 和 J 列。如果你查看评论，很容易看出如果你需要修改什么你想要不同的行为。

Option Explicit
Dim colStore
Dim initialized
' two strings that contain the columns and range of rows we want to track:
' columnsOfInterest_string could contain any number of comma-separated columns
' but rowsOfInterest_string must contain just two: first and last row
Const columnsOfInterest_string = "D,J"
Const rowsOfInterest_string = "2,1000"

' a few variables that get initialized when workbook is first opened
Dim rowsOfInterest
Dim colLookupTable
Dim rangeOfInterest As Range

Private Sub Workbook_Open()
  If IsEmpty(initialized) Then
'    MsgBox "opening workbook. Nothing has been initialized yet"
    initializeIt
  End If
End Sub

Private Sub testIt()
  Dim r1, r2, ra, rd, rad
  Dim vals, valUnion, valBlock
  ra = "A1:A5"
  rd = "D1:D5"
  rad = ra & "," & rd
  Debug.Print rad
  Set r1 = Range("A1:A5")
  Set r2 = Range("D1:D5")
  vals = Range(rad).Value
  valUnion = Union(r1, r2).Value
  valBlock = Range("A1:D5").Value
End Sub

Private Sub initializeIt()
' copy the data from the relevant ranges to a variable
' if the cell contents don't change, don't update the time stamp
  Dim thisCol, rangeAddress, cList, rRange
  Dim nRows, nCols, c, ci, ri

  ' create a "dictionary" to go from "column name" to "column index in stored array"
  Set colLookupTable = CreateObject("Scripting.Dictionary")
  ' get the list of columns as an array:
  cList = Split(columnsOfInterest_string, ",")
  nCols = UBound(cList) + 1 ' since Option Base 0

  rowsOfInterest = Split(rowsOfInterest_string, ",") ' should be just two numbers
  nRows = Val(rowsOfInterest(1)) - Val(rowsOfInterest(0)) + 1

  ' create a string with the address of the entire range of interest:
  rangeAddress = ""
  ci = 1
  For Each c In cList
    thisCol = c & rowsOfInterest(0) & ":" & c & rowsOfInterest(1)
    colLookupTable.Add c, ci    ' create lookup for index into the array
    rangeAddress = rangeAddress & thisCol & ","
    ci = ci + 1
  Next c
  rangeAddress = Left(rangeAddress, Len(rangeAddress) - 1)
  Set rangeOfInterest = Range(rangeAddress)
  ' get all the data from the complete range and store it
  colStore = ToArray(rangeOfInterest)
  initialized = True
End Sub

Function ToArray(rng) As Variant()
' With thanks to Tim Williams of StackOverflow.com
' answer http://stackoverflow.com/a/18994211/1967396

Dim arr() As Variant, r As Long, nr As Long
    Dim ar As Range, c As Range, cnum As Long, rnum As Long
    Dim col As Range

    nr = rng.Areas(1).Rows.Count
    ReDim arr(1 To nr, 1 To rng.Cells.Count / nr)
    cnum = 0
    For Each ar In rng.Areas
        For Each col In ar.Columns
        cnum = cnum + 1
        rnum = 1
        For Each c In col.Cells
            arr(rnum, cnum) = c.Value
            rnum = rnum + 1
        Next c
        Next col
    Next ar

    ToArray = arr
End Function

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim tempAddress, colOfInterest
On Error GoTo leaveSub

If IsEmpty(initialized) Then
'  MsgBox "fired sheet_change before workbook_open!"
  initializeIt
End If

With Target
        If .Count > 1 Then Exit Sub
        If Not Intersect(rangeOfInterest, .Cells) Is Nothing Then
            Application.EnableEvents = False
            If IsEmpty(.Value) Then
                .Offset(0, 2).ClearContents
            Else
                ' see if value actually changed
                tempAddress = Split(Target.Address, "$")
                colOfInterest = colLookupTable(tempAddress(1))
                If .Value = colStore(.Row - rowsOfInterest(0) + 1, colOfInterest) Then
                Else
                  colStore(.Row - rowsOfInterest(0) + 1, colOfInterest) = .Value ' update the store
                  ' update the date:
                  With .Offset(0, 2)
                    .NumberFormat = "mmm, d, h:mm:ss AM/PM"
                    .Value = Now
                  End With
                End If
            End If
        End If
    End With
leaveSub:
  Application.EnableEvents = True

End Sub
于 2013-09-23T15:50:18.033 回答