8

「Worksheet_SelectionChange」イベントで起動するマクロがあります。マクロは 1 つの列のデータを検証し、間違っている場合はセルの背景色を変更します。

問題は、マクロを実行した後、すべてのドキュメントの変更履歴 (Ctrl Z) がクリアされ、検証しなかった他のセルの変更履歴もクリアされることです。

どうすればこの問題を解決できますか?

ありがとう。

4

2 に答える 2

4

この問題が発生したため、カスタムの元に戻す機能を作成する必要がありました。次の点を除いて、ネイティブの元に戻すと非常によく似た動作をします。もう少し注意を払って処理できると確信しています。

1) カスタム取り消しでは、書式設定は取り消されません。テキストのみ。

2) カスタムの元に戻すは、カスタム スタックの最後まで行われます。これが発生すると、スタックがクリアされ、ネイティブの元に戻す機能のように最後の 2 つのアイテムが切り替わりません。

2.1) REDO 機能がありません。

このコードの作業コピーをダウンロードします。

VBAProject レイアウトのスクリーンショット

モジュール UndoModule

Public UndoStack() As UndoStackEntry
Private Const UndoMaxEntries = 50

Public Sub SaveUndo(ByVal newUndo As UndoStackEntry)

    'Save the last undo object
    If Not newUndo Is Nothing Then
        Call AddUndo(newUndo)
    End If

End Sub

Public Sub Undo()

    'Appy last undo from the stack and remove it from the array
    Dim previousEdit As UndoStackEntry
    Set previousEdit = GetLastUndo()
    If Not previousEdit Is Nothing Then
        Dim previousEventState As Boolean: previousEventState = Application.EnableEvents
        Application.EnableEvents = False
        Range(previousEdit.Address).Select
        Range(previousEdit.Address).Value = previousEdit.Value
        Application.EnableEvents = previousEventState

        Call RemoveLastUndo
    End If

End Sub

Private Function AddUndo(newUndo As UndoStackEntry) As Integer

    If UndoMaxEntries < GetCount() Then
        Call RemoveFirstUndo
    End If

    On Error GoTo ErrorHandler

    ReDim Preserve UndoStack(UBound(UndoStack) + 1)
    Set UndoStack(UBound(UndoStack)) = newUndo

    AddUndo = UBound(UndoStack)

ExitFunction:
    Exit Function

ErrorHandler:
    ReDim UndoStack(0)
    Resume Next

End Function

Private Function GetLastUndo() As UndoStackEntry

    Dim undoCount As Integer: undoCount = GetCount()
    If undoCount > 0 Then
        Set GetLastUndo = UndoStack(undoCount - 1)
    End If

End Function

Private Function RemoveFirstUndo() As Boolean

    On Error GoTo ExitFunction

    RemoveFirstUndo = False
    Dim i As Integer
    For i = 1 To UBound(UndoStack)
        Set UndoStack(i - 1) = UndoStack(i)
    Next i
    ReDim Preserve UndoStack(UBound(UndoStack) - 1)
    RemoveFirstUndo = True

    ExitFunction:
       Exit Function

End Function

Private Function RemoveLastUndo() As Boolean

    RemoveLastUndo = False
    Dim undoCount As Integer: undoCount = GetCount()
    If undoCount > 1 Then
        ReDim Preserve UndoStack(undoCount - 2)
        RemoveLastUndo = True
    ElseIf undoCount = 1 Then
        Erase UndoStack
        RemoveLastUndo = True
    End If

End Function

Private Function GetCount() As Long

    GetCount = 0
    On Error Resume Next
    GetCount = UBound(UndoStack) + 1

End Function

クラス モジュール UndoStackEntry

 Public Address As String
 Public Value As Variant

また、WORKBOOK Excel オブジェクトの次のイベントにアタッチする必要があります。

Public Sub WorkbookUndo()

    On Error GoTo ErrHandler
    ThisWorkbook.ActiveSheet.PageUndo

ErrExit:
    Exit Sub

ErrHandler:
    On Error GoTo ErrExit
    Application.Undo
    Resume ErrExit

End Sub

最後に、元に戻す必要がある各シートのイベントに次のコードを追加する必要があります。

Dim tmpUndo As UndoStackEntry
Dim pageUndoStack() As UndoStackEntry

Private Sub OnSelectionUndoCapture(ByVal Target As Range)
    Set tmpUndo = New UndoStackEntry
    tmpUndo.Address = Target.Address
    tmpUndo.Value = Target.Value
    UndoModule.UndoStack = pageUndoStack
End Sub

Private Sub OnChangeUndoCapture(ByVal Target As Range)
    Application.OnKey "^{z}", "ThisWorkbook.WorkbookUndo"
    Application.OnUndo "Undo Procedure", "ThisWorkbook.WorkbookUndo"

    If Not Application.Intersect(Target, Range(tmpUndo.Address)) Is Nothing Then
        If Target.Value <> tmpUndo.Value Or Empty = Target.Value Then
            UndoModule.UndoStack = pageUndoStack
            Call UndoModule.SaveUndo(tmpUndo)
            pageUndoStack = UndoModule.UndoStack
        End If
    End If
End Sub

Public Sub PageUndo()
    UndoModule.UndoStack = pageUndoStack
    Call UndoModule.Undo
    pageUndoStack = UndoModule.UndoStack
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    'Stash away the value of the first cell in the selected range
    On Error Resume Next

    Call OnSelectionUndoCapture(Target)
    oldValue = Target.Value
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

    On Error Resume Next

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    If tmpUndo.Value <> Target.Value Then
        'Do some stuff
    End If

    Call OnChangeUndoCapture(Target)

    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub
于 2016-06-10T13:34:41.193 に答える