Как разрешить несколько последовательных отменить в excel vba?

У меня есть книга Excel, которая должна позволить пользователю отменить несколько изменений на листе. Я искал в Интернете на каждом форуме, о котором я могу думать, и не смог найти ответ для этого. Я понимаю, что есть проблема с проблемой отмены в excel, когда выполняются макросы, и они смогли обработать это с помощью кода, полученного из here.Как разрешить несколько последовательных отменить в excel vba?

Это мой текущий процесс:

Создание глобальных переменных для хранения начального состояния книги, и изменения. Код выглядит следующим образом:

Private Type SaveRange 
    Val As Variant 
    Addr As String 
End Type 

Private OldWorkbook As Workbook 
Private OldSheet As Worksheet 
Private OldSelection() As SaveRange 
Private OldSelectionCount As Integer 
Private InitialState() As SaveRange 
Private InitialStateCount As Integer

Получить начальное состояние книги путем создания массива (InitialState), удерживающий значения всех ячеек в суб Workbook_Open. Код выглядит следующим образом:

Private Sub Workbook_Open() 
    GetInitialCellState 
End Sub 

Private Sub GetInitialCellState() 
    Dim i As Integer, j As Integer, count As Integer 
    Dim cellVal As String 
    Dim sampID As Range, cell As Range 
    Dim e1664 As Workbook 
    Dim rawData As Worksheet 
    Dim table As Range 
    Dim LastRow As Integer, LastCol As Integer 

    LastRow = Worksheets("Raw_Data").Range("A65536").End(xlUp).Row 
    LastCol = Worksheets("Raw_Data").UsedRange.Columns.count 
    Set e1664 = ThisWorkbook 
    Set rawData = e1664.Sheets("Raw_Data") 
    Set sampID = rawData.Range("SAMPLEID").Offset(1) 
    Set table = rawData.Range(sampID, "R" & LastRow) 

    i = 0 
    j = 0 
    count = 0 
    ReDim InitialState(i) 
    For i = 0 To (LastRow - sampID.Row) 
     For j = 0 To LastCol 
      ReDim Preserve InitialState(count) 
      InitialState(count).Addr = sampID.Offset(i, j).address 
      InitialState(count).Val = sampID.Offset(i, j).Value 
      count = count + 1 
     Next j 
    Next i 
    InitialStateCount = count - 1 
End Sub

Когда значение вводится в ячейку, сохранить значение, введенное в другой массив (OldSelection), держащего введенное значение. Это делается в подменю Workbook_Change. Важными частями здесь являются Call SaveState (OldSelectionCount, Target.Cells.address, Target.Cells.Value) и Application.OnUndo «Отменить последнее действие», «GI.OR.E1664.20150915_DRAFT.xlt! Sheet1. RevertState ", которые показаны в цифрах 4 и 5 ниже. Код выглядит следующим образом:

Private Sub Worksheet_Change(ByVal Target As Range) 
    Dim cell As Range, InWtRange As Boolean 
    Dim y As Integer, x As Integer, count As Integer 
    Dim LastRow As Integer 

    'This saves the changed values of the cells 
    Call SaveState(OldSelectionCount, Target.Cells.address, Target.Cells.Value) 

try: 
    y = Me.Range("SampleID").Row 

    If Target.Column > 5 And Target.Column < 8 Then 
     If Range("A" & Target.Row).Value = Range("A" & Target.Row + 1).Value Then 
      If Range("A" & Target.Row + 1).Value <> "" Then 
       Range(Target.address).Offset(1).Value = Range(Target.address).Value 
      End If 
     End If 
    Else 
     'If initial pan weight add start date 
     If Target.Column = 8 Then 
      If Target.Cells.Text <> "" Then 
       If Not IsNumeric(Target.Cells.Value) Then 
        GoTo Finally 
       Else 
        Application.EnableEvents = False 
        Range("StartDate").Offset(Target.Cells.Row - y).Value = Format(Now(), "MM/DD/YY HH:NN:SS") 
        Application.EnableEvents = True 
       End If 
      Else 
       Application.EnableEvents = False 
       Range("StartDate").Offset(Target.Cells.Row - y).Value = "" 
       Application.EnableEvents = True 
      End If 
     End If 
    End If 

    LastRow = Worksheets("Raw_Data").Range("A65536").End(xlUp).Row 
    For Each cell In Target.Cells 
      'Debug.Print Target.Cells.Address 
     If cell.Value <> "" Then 
      If Not IsNumeric(cell.Value) Then GoTo Finally 
      Select Case cell.Column 
       Case 9, 11, 13 
        Application.EnableEvents = False 
        If CalcHEM(cell.Row - y, cell.Column) Then 
        End If 
        Application.EnableEvents = True 
       Case Else 
        'Do nothing yet 
       End Select 
      'Cells(Target.Row + 1, Target.Column).Select 
     End If 
    Next 

    'This will allow the changed values to be undone 
    Application.OnUndo "Undo the last action", "GI.OR.E1664.20150915_DRAFT.xlt!Sheet1.RevertState" 

Finally: 
    If Application.EnableEvents = False Then Application.EnableEvents = True 
    Exit Sub 

Catch: 
    MsgBox "An error has occurred in the code execution." & vbNewLine _ 
      & "The message text of the error is: " & Error(Err), vbInformation, "TSSCalcs.AddQC" 
    Resume Finally 

End Sub

Суб SaveState сохранит добавить в массив OldSelection, любые значения, которые изменились. Код выглядит следующим образом:

Private Sub SaveState(count As Integer, Addr As String, Val As Double) 
    Dim i As Integer 
    Dim cell As Range 

    If TypeName(Selection) <> "Range" Or Selection.count > 1 Then Exit Sub 

    ReDim Preserve OldSelection(count) 
    Set OldWorkbook = ActiveWorkbook 
    Set OldSheet = ActiveSheet 
    For Each cell In Selection 
     OldSelection(count).Addr = Addr 
     OldSelection(count).Val = Val 
    Next cell 
    OldSelectionCount = OldSelectionCount + 1 
End Sub

Суб RevertState будет отменить только последнее действие! Я не могу разрешить отмену последней записи. Код выглядит следующим образом:

Private Sub RevertState() 
    Dim i As Integer, index As Integer 
    Dim prevItem As SaveRange 
    Dim address As String 

    OldWorkbook.Activate 
    OldSheet.Activate 

    Application.EnableEvents = False 
     address = OldSelection(OldSelectionCount - 1).Addr 
     OldSelectionCount = OldSelectionCount - 2 
     If OldSelectionCount <= 0 Then 
      ReDim OldSelection(0) 
      For i = 0 To InitialStateCount 
       If InitialState(i).Addr = address Then 
        prevItem.Val = InitialState(i).Val 
        index = i 
       End If 
      Next i 
      Range(InitialState(index).Addr).Formula = prevItem.Val 
     Else 
      ReDim Preserve OldSelection(OldSelectionCount) 
      For i = 0 To OldSelectionCount 
       If OldSelection(i).Addr = address Then 
        prevItem.Val = OldSelection(i).Val 
        index = i 
       End If 
      Next i 
      'OldSelectionCount = OldSelectionCount + 1 
      Range(OldSelection(index).Addr).Formula = prevItem.Val 
     End If 
     OldSelectionCount = OldSelectionCount + 1 
    Application.EnableEvents = True 
End Sub

Кто-нибудь знает способ, чтобы позволить многократный откат, чтобы сделать?

Любая помощь для решения этой проблемы была бы принята с благодарностью!

источник

2015-09-17 DiggityCS

Работал над аналогичной проблемой в прошлом (а не в Excel), и идея заключалась в создании своего рода структуры стека, чтобы сохранить последовательность состояний, вместо сохранения только одного состояния. –

Вы можете найти эту статью и пример, интересные вашему проекту. Создание обработчика отмены для отмены изменений, выполненных с помощью Excel VBA и примера отмены отладки – skkakkar

Две ссылки, которые вы мне отправили, не работают, но ссылка, содержащая информацию, на которую вы ссылаетесь, должна быть [здесь] (http://www.jkp-ads.com/Articles/ UndoWithVBA00.asp). Хотя это хорошая информация, код требует большей отладки, чем того стоит. Реальная проблема связана с методом onUndo. Я хотел бы использовать Microsoft, если это возможно, но может быть проще просто написать мою собственную. Если я найду решение, я опубликую его. – DiggityCS

После исследования функции Undo на MSDN here я обнаружил, что функция Application.Undo отменяет последнее действие, предпринятое пользователем. Вместо того, чтобы пытаться отменить функциональность Microsoft для отмены, я добавил свои собственные кнопки отмены и повтора, которые работают так же, как кнопки Microsoft. Я добавил два модуля класса: ActionState (содержит свойства для рабочей книги, рабочего листа, адреса и значения ячейки) ActionStates (коллекция объектов ActionState вместе с функциями для добавления, удаления, получения элемента, очистки коллекции, подсчета и свойства для CurrentState и InitialState рабочего листа). Новый процесс выглядит следующим образом:

Получить начальное состояние всех ячеек в листе и добавить их в массив стека отмены (см GetInitialCellStates() метод в модуле UndoFuntionality).
Когда элемент добавлен в ячейку, добавьте адрес и значение в массив (см. Метод SaveState() в модуле UndoFunctionality) и обновите индекс текущего состояния до последнего добавленного значения. Повторите этот шаг с любыми дополнительными значениями.
Когда это будет сделано, оно позволяет отменить кнопку.
Если нажата кнопка отмены, она уменьшит индекс текущего состояния и включит кнопку повтора (см. Функцию RevertState() в модуле UndoFunctionality).
Если кнопка повтора нажата, она увеличит индекс текущего состояния (см. Функцию ProgressState() в модуле UndoFunctionality).

Код класса ActionState выглядит следующим образом:

Private asAddr As String 
Private asVal As Variant 
Private asWorkbook As Workbook 
Private asWorksheet As Worksheet 

Private Sub Class_Initalize() 
    Set asWorkbook = New Workbook 
    Set asWorksheet = New Worksheet 
End Sub 

''''''''''''''''''' 
' Addr property 
''''''''''''''''''' 
Public Property Get Addr() As String 
    Addr = asAddr 
End Property 

Public Property Let Addr(Value As String) 
    asAddr = Value 
End Property 

''''''''''''''''''' 
' Val property 
''''''''''''''''''' 
Public Property Get Val() As Variant 
    Val = asVal 
End Property 

Public Property Let Val(Value As Variant) 
    asVal = Value 
End Property 

''''''''''''''''''' 
' Wkbook property 
''''''''''''''''''' 
Public Property Get Wkbook() As Workbook 
    Set Wkbook = asWorkbook 
End Property 

Public Property Let Wkbook(Value As Workbook) 
    Set asWorkbook = Value 
End Property 

''''''''''''''''''' 
' WkSheet property 
''''''''''''''''''' 
Public Property Get Wksheet() As Worksheet 
    Set Wksheet = asWorksheet 
End Property 

Public Property Let Wksheet(Value As Worksheet) 
    Set asWorksheet = Value 
End Property

Код класса ActionStates выглядит следующим образом:

Private asStates As Collection 
Private currState As Integer 
Private initState As Integer 

Private Sub Class_Initialize() 
    Set asStates = New Collection 
End Sub 

Private Sub Class_Termitate() 
    Set asStates = Nothing 
End Sub 

'''''''''''''''''''''''''''' 
' InitialState property 
'''''''''''''''''''''''''''' 
Public Property Get InitialState() As Integer 
    InitialState = initState 
End Property 

Public Property Let InitialState(Value As Integer) 
    initState = Value 
End Property 

'''''''''''''''''''''''''''' 
' CurrentState property 
'''''''''''''''''''''''''''' 
Public Property Get CurrentState() As Integer 
    CurrentState = currState 
End Property 

Public Property Let CurrentState(Value As Integer) 
    currState = Value 
End Property 

'''''''''''''''''''''''''''' 
' Add method 
'''''''''''''''''''''''''''' 
Public Function Add(Addr As String, Val As Variant) As clsActionState 
    Dim asNew As New clsActionState 
    With asNew 
     .Addr = Addr 
     .Val = Val 
    End With 
    asStates.Add asNew 
End Function 

'''''''''''''''''''''''''''' 
' Count method 
'''''''''''''''''''''''''''' 
Public Property Get count() As Long 
    If TypeName(asStates) = "Nothing" Then 
     Set asStates = New Collection 
    End If 
    count = asStates.count 
End Property 

'''''''''''''''''''''''''''' 
' Item method 
'''''''''''''''''''''''''''' 
Public Function Item(index As Integer) As clsActionState 
    Set Item = asStates.Item(index) 
End Function 

'''''''''''''''''''''''''''' 
' Remove method 
'''''''''''''''''''''''''''' 
Public Function Remove(index As Integer) 
    If TypeName(asStates) = "Nothing" Then 
     Set asStates = New Collection 
    End If 
    asStates.Remove (index) 
End Function 

'''''''''''''''''''''''''''' 
' Clear method 
'''''''''''''''''''''''''''' 
Public Sub Clear() 
    Dim x As Integer 
    For x = 1 To asStates.count 
     asStates.Remove (1) 
    Next x 
End Sub

Эти два класса используются в новом модуле, называемом UndoFunctionality следующим образом:

Option Explicit 

Public ActionState As New clsActionState 
Public ActionStates As New clsActionStates 
Public undoChange As Boolean 

Public Sub SaveState(count As Integer, Addr As String, Val As Variant) 
    Dim i As Integer 
    Dim cell As Range 

    If TypeName(Selection) <> "Range" Or Selection.count > 1 Then Exit Sub 

    With ActionState 
     .Wkbook = ActiveWorkbook 
     .Wksheet = ActiveSheet 
    End With 

    If ActionStates.CurrentState < ActionStates.count Then 
     For i = ActionStates.CurrentState + 1 To ActionStates.count 
      ActionStates.Remove (ActionStates.count) 
     Next i 
    End If 

    For Each cell In Selection 
     ActionState.Addr = Addr 
     ActionState.Val = Val 
    Next cell 

    ActionStates.Add ActionState.Addr, ActionState.Val 
    ActionStates.CurrentState = ActionStates.count 
End Sub 

Public Sub RevertState() 
    Dim i As Integer, index As Integer 
    Dim prevItem As New clsActionState 
    Dim Address As String 

    'undoChange = True 

    With ActionState 
     .Wkbook.Activate 
     .Wksheet.Activate 
    End With 

    Application.EnableEvents = False 
     Address = ActionStates.Item(ActionStates.CurrentState).Addr 
     ActionStates.CurrentState = ActionStates.CurrentState - 1 
     For i = 1 To ActionStates.CurrentState 
      If ActionStates.Item(i).Addr = Address Then 
       prevItem.Val = ActionStates.Item(i).Val 
       index = i 
      End If 
     Next i 
     Range(ActionStates.Item(index).Addr).Formula = prevItem.Val 
    Application.EnableEvents = True 

    UndoButtonAvailability 
    RedoButtonAvailability 
End Sub 

Public Sub ProgressState() 
    Dim i As Integer, index As Integer 
    Dim nextItem As New clsActionState 
    Dim Address As String 

    With ActionState 
     .Wkbook.Activate 
     .Wksheet.Activate 
    End With 

    Application.EnableEvents = False 
     ActionStates.CurrentState = ActionStates.CurrentState + 1 
     With nextItem 
      .Addr = ActionStates.Item(ActionStates.CurrentState).Addr 
      .Val = ActionStates.Item(ActionStates.CurrentState).Val 
     End With 
     Range(ActionStates.Item(ActionStates.CurrentState).Addr).Formula = nextItem.Val 
    Application.EnableEvents = True 

    UndoButtonAvailability 
    RedoButtonAvailability 
End Sub 

Public Sub GetInitialCellStates() 
    Dim i As Integer, j As Integer, count As Integer 
    Dim cellVal As String 
    Dim sampID As Range, cell As Range 
    Dim e1664 As Workbook 
    Dim rawData As Worksheet 
    Dim table As Range 
    Dim LastRow As Integer, LastCol As Integer 

    ThisWorkbook.Worksheets("Raw_Data").Activate 

    If ActionStates.count > 0 Then 
     ActionStates.Clear 
    End If 

    LastRow = Worksheets("Raw_Data").Range("A65536").End(xlUp).Row 
    LastCol = Worksheets("Raw_Data").UsedRange.Columns.count 
    Set e1664 = ThisWorkbook 
    Set rawData = e1664.Sheets("Raw_Data") 
    Set sampID = rawData.Range("SAMPLEID").Offset(1) 
    Set table = rawData.Range(sampID, "R" & LastRow) 
    i = 0 
    j = 0 
    count = 0 

    For i = 0 To (LastRow - sampID.Row) 
     For j = 0 To LastCol 
      ActionState.Addr = sampID.Offset(i, j).Address 
      ActionState.Val = sampID.Offset(i, j).Value 
      ActionStates.Add ActionState.Addr, ActionState.Val 
      count = count + 1 
     Next j 
    Next i 

    ActionStates.InitialState = count 
    ActionStates.CurrentState = count 
    undoChange = False 
    UndoButtonAvailability 
    RedoButtonAvailability 
End Sub 

Public Sub UndoButtonAvailability() 
    Dim rawData As Worksheet 

    Set rawData = ThisWorkbook.Sheets("Raw_Data") 

    If ActionStates.CurrentState <= ActionStates.InitialState Then 
     rawData.Buttons("UndoButton").Enabled = False 
     rawData.Buttons("UndoButton").Font.ColorIndex = 16 
    Else 
     rawData.Buttons("UndoButton").Enabled = True 
     rawData.Buttons("UndoButton").Font.ColorIndex = 1 
    End If 
End Sub 

Public Sub RedoButtonAvailability() 
    Dim rawData As Worksheet 

    Set rawData = ThisWorkbook.Sheets("Raw_Data") 

    If ActionStates.CurrentState < ActionStates.count Then 
     rawData.Buttons("RedoButton").Enabled = True 
     rawData.Buttons("RedoButton").Font.ColorIndex = 1 
    Else 
     rawData.Buttons("RedoButton").Enabled = False 
     rawData.Buttons("RedoButton").Font.ColorIndex = 16 
    End If 
End Sub 

Sub UndoButton_Click() 
    Dim rawData As Worksheet 

    Set rawData = ThisWorkbook.Sheets("Raw_Data") 

    If rawData.Buttons("UndoButton").Enabled Then 
     RevertState 
    End If 
End Sub 

Sub RedoButton_Click() 
    Dim rawData As Worksheet 

    Set rawData = ThisWorkbook.Sheets("Raw_Data") 

    If rawData.Buttons("RedoButton").Enabled Then 
     ProgressState 
    End If 
End Sub

T он GetInitialStates метод используется в Workbook_Open события следующим образом:

UndoFunctionality.GetInitialCellStates

И событие Worksheet_Change в лист выглядит следующим образом:

Option Explicit 

Private Sub Worksheet_Change(ByVal Target As Range) 
    Dim cell As Range, InWtRange As Boolean 
    Dim y As Integer, x As Integer, count As Integer 
    Dim LastRow As Integer 

    'This saves the changed values of the cells 
    Call SaveState(ActionStates.CurrentState, Target.Cells.Address, Target.Cells.Value) 

try: 
    y = Me.Range("SampleID").Row 

    If Target.Column > 5 And Target.Column < 8 Then 
     If Range("A" & Target.Row).Value = Range("A" & Target.Row + 1).Value Then 
      If Range("A" & Target.Row + 1).Value <> "" Then 
       Range(Target.Address).Offset(1).Value = Range(Target.Address).Value 
      End If 
     End If 
    Else 
     'If initial pan weight add start date 
     If Target.Column = 8 Then 
      If Target.Cells.Text <> "" Then 
       If Not IsNumeric(Target.Cells.Value) Then 
        GoTo Finally 
       Else 
        Application.EnableEvents = False 
        Range("StartDate").Offset(Target.Cells.Row - y).Value = Format(Now(), "MM/DD/YY HH:NN:SS") 
        Application.EnableEvents = True 
       End If 
      Else 
       Application.EnableEvents = False 
       Range("StartDate").Offset(Target.Cells.Row - y).Value = "" 
       Application.EnableEvents = True 
      End If 
     End If 
    End If 

    LastRow = Worksheets("Raw_Data").Range("A65536").End(xlUp).Row 
    For Each cell In Target.Cells 
     If cell.Value <> "" Then 
      If Not IsNumeric(cell.Value) Then GoTo Finally 
      Select Case cell.Column 
       Case 9, 11, 13 
        Application.EnableEvents = False 
        If CalcHEM(cell.Row - y, cell.Column) Then 
        End If 
        Application.EnableEvents = True 
       Case Else 
        'Do nothing yet 
       End Select 
     End If 
    Next 

    UndoFunctionality.UndoButtonAvailability 
    UndoFunctionality.RedoButtonAvailability 

Finally: 
    If Application.EnableEvents = False Then Application.EnableEvents = True 
    Exit Sub 

Catch: 
    MsgBox "An error has occurred in the code execution." & vbNewLine _ 
      & "The message text of the error is: " & Error(Err), vbInformation, "TSSCalcs.AddQC" 
    Resume Finally 

End Sub

Единственное, что осталось, чтобы добавить две кнопки на листе и назначьте макрос, используемый для событий UndoButton_Click() и RedoButton_Click(), которые будут запускать методы RevertState() и ProgressState().

источник

2015-09-21 17:13:06 DiggityCS

Я нашел небольшой трюк, используя Application.OnTime. Таким образом, можно повторно использовать Undo. Кнопка повтора не является кнопкой «Повторить». Вы можете найти его в меню «Правка» или поместить его на ленту. Я использую Excel 2003. Вот рабочий образец. Поместите код в модуль ThisWorkbook.

Dim Undos As New Collection 

Sub Change() 
    ' push previous cell values to the end of your undo array 
    Undos.Add ActiveCell.Value 
    ' change the cell values as you wish 
    ActiveCell.Value = "(" + ActiveCell.Value + ")" 

    PlanUndo 
    PlanRepeat 
End Sub 

Sub Undo() 
    ' make sure the undo array is not empty 
    If (Undos.Count > 0) Then 
    ' pop previous cell values from the end of your undo array 
    Dim Value 
    Value = Undos.Item(Undos.Count) 
    Undos.Remove Undos.Count 
    ' revert the cell values 
    ActiveCell.Value = Value 
    End If 

    If (Undos.Count > 0) Then 
    PlanUndo 
    End If 
    PlanRepeat 
End Sub 

Function PlanUndo() 
    Application.OnTime Now, "ThisWorkbook.SetUndo" 
End Function 

Sub SetUndo() 
    Application.OnUndo "Undo last change", "ThisWorkbook.Undo" 
End Sub 

Function PlanRepeat() 
    Application.OnTime Now, "ThisWorkbook.SetRepeat" 
End Function 

Sub SetRepeat() 
    Application.OnRepeat "Repeat last change", "ThisWorkbook.Change" 
End Sub

источник

2017-08-26 00:44:20 MarekJ47

Как разрешить несколько последовательных отменить в excel vba?

ответ

Смежные вопросы