VBA静态时间戳仅在单元格数据发生更改时—而不是在数据刷新时。标准VBA不工作
我是VBA新手，我会尽我所能解释我的问题。 我有一个工作簿，它可以将一系列任务与Outlook任务双向同步，工作正常。 我还有一个宏，每当“状态”列（D列）更改时，它都会创建一个静态时间夯实。 问题是，每次我打开工作表并与Outlook同步时，它都会刷新D列（以及工作表的其余部分），即使状态文本保持不变，时间戳也会更新。 下面是我用来创建时间戳的宏：是否有一种方法可以修改它，使其仅在单元格（D列）中的实际文本更改（即“正在进行”变为“正在等待”）时使用时间戳，而不仅仅是在工作簿同步和刷新所有数据时使用 非常感谢你！！！ 下面修订的代码--这是从“Microsoft Excel对象”文件夹中的“ThisWorkbook”与Outlook同步的代码VBA静态时间戳仅在单元格数据发生更改时—而不是在数据刷新时。标准VBA不工作,vba,timestamp,Vba,Timestamp,我是VBA新手，我会尽我所能解释我的问题。 我有一个工作簿，它可以将一系列任务与Outlook任务双向同步，工作正常。 我还有一个宏，每当“状态”列（D列）更改时，它都会创建一个静态时间夯实。 问题是，每次我打开工作表并与Outlook同步时，它都会刷新D列（以及工作表的其余部分），即使状态文本保持不变，时间戳也会更新。 下面是我用来创建时间戳的宏：是否有一种方法可以修改它，使其仅在单元格（D列）中的实际文本更改（即“正在进行”变为“正在等待”）时使用时间戳，而不仅仅是在工作簿同步和刷新所有数据
”-->声明一些常量
'根据需要编辑下面的常量，使其正确反映电子表格中显示的列号'
Const EXC_CLIENT=1
Const EXC_SUBJECT=2
Const EXC_START=5
Const EXC_STATUS=4
常数EXC_到期=8
常数EXC_EID=26
Const PROC_NAME=“Outlook同步”
'从此点开始，不要更改任何常量
常量oltasknotstart=0
常数olTaskInProgress=1
常量olTaskComplete=2
常数olTaskWaiting=3
常量olTaskDeferred=4
常数olText=1
常数=6
常数olFolderTasks=13
Const DESKTOP_READOBJECTS=&H1&
'-->声明一些变量
Dim olkApp作为对象_
作为对象的奥尔克斯_
作为对象的olkFld_
以奥尔克茨克为对象_
olkPrp作为对象_
excWks作为Excel.工作表_
只要_
strun作为字符串_
布尔型
私有子初始化Excel（）
Set excWks=Application.ActiveWorkbook.Sheets（1）
lngRow=2
strun=格式（现在为“yyyy-mm-dd-hh-nn-ss”）
端接头
专用子交换机Excel（）
设置excWks=无
端接头
私有子初始化Outlook（）
设置olkApp=CreateObject（“Outlook.Application”）
设置olkSes=olkApp.GetNamespace（“MAPI”）
olkSes.Logon olkApp.DefaultProfileName
设置olkFld=olkSes.GetDefaultFolder（olFolderTasks）
端接头
专用子停用outlook（）
奥尔克斯，下线
设置olkFld=Nothing
设置olkSes=Nothing
设置olkApp=Nothing
端接头
私有子工作簿\u在保存之前（ByVal SaveAsUI为布尔值，Cancel为布尔值）
'-->保存工作簿时，您将有机会从Excel同步到Outlook
初始化Excel“准备Excel进行同步”
初始化Outlook“准备Outlook进行同步”
Excel2Outlook'从Excel同步到Outlook
停用Excel“清理Excel”
停用Outlook“清理Outlook”
端接头
私有子工作簿_Open（）
'-->打开工作簿时，您将有机会将数据从Outlook同步到Excel
bolSkp=False“如果您不想在打开/关闭电子表格时被提示运行同步，请将此设置为True。
初始化Excel“准备Excel进行同步”
初始化Outlook“准备Outlook进行同步”
Outlook2Excel'从Outlook同步到Excel
停用Excel“清理Excel”
停用Outlook“清理Outlook”
端接头
专用子系统Excel2Outlook（）
如果不是，那么
如果MsgBox（“我应该将任务同步到Outlook吗？”，vbQuestion+vbYesNo，PROC_NAME）=vbYes，则
直到取出。单元格（lngRow，1）=“
选择大小写excWks.Cells（lngRow，EXC_EID）
案例“”
Set olkTsk=olkFld.Items.Add（）
与奥尔克茨克
.UserProperties.Add“ExcelTaskList”，olYesNo，True
.UserProperties.Item（“ExcelTaskList”）.Value=True
.UserProperties.Add“Synced”，olText
.UserProperties.Item（“已同步”）.Value=strun
拯救
以
excWks.Cells（lngRow，EXC_EID）=olkTsk.EntryID
其他情况
设置olkTsk=olkSes.GetItemFromID（excWks.Cells（lngRow，EXC_-EID））
结束选择
与奥尔克茨克
.Subject=excWks.Cells（lngRow，EXC_客户端）&“/”和excWks.Cells（lngRow，EXC_Subject）
如果IsDate（excWks.Cells（lngRow，EXC_START））则.StartDate=excWks.Cells（lngRow，EXC_START）
如果IsDate（excWks.Cells（lngRow，EXC_DUE））则.DueDate=excWks.Cells（lngRow，EXC_DUE）
选择案例excWks.CELL（lngRow，EXC_状态）
案件“完成”
.Status=olTaskComplete
“延期”案件
.Status=olTaskDeferred
案件“进行中”
.Status=olTaskInProgress
案例“未启动”
.Status=olTaskNotStarted
案件“等待”
.Status=olTaskWaiting
结束选择
olkTsk.UserProperties.Item（“已同步”）.Value=strun
拯救
以
lngRow=lngRow+1
环
对于LNROW=olkFld.Items.Count到1步骤-1
设置olkTsk=olkFld.Items（lngRow）
设置olkPrp=olkTsk.UserProperties.Find（“ExcelTaskList”，True）
如果TypeName（olkPrp）“Nothing”，则
如果olkTsk.UserProperties.Item（“Synced”）.Value'--> 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
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
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
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