2

私は VBA に非常に慣れていないので、私の問題を説明するために最善を尽くします。タスクのリストを Outlook のタスクと双方向に同期するワークブックがありますが、問題なく動作しています。また、「ステータス」列 (列 D) が変更されるたびに静的タイムスタンプを作成するマクロもあります。問題は、ワークシートを開いて Outlook と同期するたびに、列 D が (ワークシートの残りの部分と共に) 更新され、ステータス テキストが同じままであってもタイム スタンプが更新されることです。以下は、タイム スタンプを作成するために使用しているマクロです。セル内の実際のテキスト (列 D) が変更されたとき (つまり、「進行中」が「待機中」になるとき) にのみタイム スタンプを作成するように変更する方法はありますか?ワークブックがすべてのデータを同期して更新するときだけではありませんか?

どうもありがとう！！！以下の改訂されたコード -- これは、"Microsoft Excel Objects" フォルダ内の "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イベントが発生したときに、実際の新しい値を参照と比較します。2 つの値が同じでない場合は、必要なアクションを実行してください。

EDITEDコードの最初のバージョンが機能していないことに基づいて、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

2番目の編集あなたが与えたコードに基づいて、次の「コードマージ」が機能するものを生成するはずだと思います。私はそれをテストすることはできませんが、これで問題が解決するかどうか、またはまだ問題があるかどうかをお知らせください。ここにはいくつかの TEST MESSAGE があります。すべてが機能したら取り出してください (プログラム フローが正しいことを確認するのに役立ちます)。このすべてのコードを 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

3 番目 (そして最後?) の編集複数の列を「追跡」できるようにコードを更新しました。これはかなり一般的です。物事を単純にするために、変更された関数だけを投稿します - 上記のコードでそれらを置き換えます。列 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 に答える