Excel vba отмена действия

'Создаем свой пользовательский тип данных
Type SaveRange
    vFormula As Variant
    sAddr As String
    lColor As Long
    lColorIndex As Long
End Type
'Переменные для запоминания данных
Public wbWBook As Excel.Workbook
Public wsSh As Excel.Worksheet
Public vOldVals() As SaveRange
'---------------------------------------------------------------------------------------
' Procedure : Fill_Numbers
' Purpose   : Основная процедура. Это тот код, который вносит изменения на лист
'             и действия которого нам необходимо отменить
'             Процедура заполняет выделенные ячейки номерами
'             и изменяет цвет заливки
'---------------------------------------------------------------------------------------
Sub Fill_Numbers()
    Dim rCell As Range, li As Long
    '   Сначала запоминаем значения выделенных ячеек на листе
    ReDim vOldVals(1 To Selection.Count)
    'Запоминаем активную книгу
    'это на случай, если отмена действий будет производиться из другой книги
    Set wbWBook = ActiveWorkbook
    'Запоминаем активный лист
    'на случай, если отмена действий будет производиться из другого листа
    Set wsSh = ActiveSheet
    'Запоминаем значения(заносим в массив)
    li = 1
    For Each rCell In Selection
        'запоминаем адрес ячейки
        vOldVals(li).sAddr = rCell.Address
        'запоминаем формулу(если нет формулы - значение)
        vOldVals(li).vFormula = rCell.Formula
        'запоминаем цвет заливки ячейки
        vOldVals(li).lColor = rCell.Interior.Color
        'запоминаем индекс цвета заливки(чтобы на заливать бесцветные ячейки)
        vOldVals(li).lColorIndex = rCell.Interior.ColorIndex
        li = li + 1
    Next rCell
    '======================================
    'Выполняем основные действия(собственно тот код, который надо будет отменить)
    li = 1
    For Each rCell In Selection
        rCell = li
        rCell.Interior.ColorIndex = li
        li = li + 1
    Next rCell
    '======================================
    'Назначаем стандартному вызову отмены действий выполнение нашего макроса возвращения значений
    Application.OnUndo "Отменить заполнение ячеек номерами", "Restore_Vals"
End Sub
 
'---------------------------------------------------------------------------------------
' Procedure : Restore_Vals
' Purpose   : Процедура отмены действия(возврат значений)
'---------------------------------------------------------------------------------------
Sub Restore_Vals()
    Dim li As Long
    'В случае непредвиденной ошибки переходим на метку
    'и показываем сообщение об ошибке
    On Error GoTo Erreble
    'Активируем книгу, в которой были сделаны изменения
    wbWBook.Activate
    'Активируем лист, в котором были сделаны изменения
    wsSh.Activate
    'Возвращаем значения
    For li = 1 To UBound(vOldVals)
        Range(vOldVals(li).sAddr).Formula = vOldVals(li).vFormula
        'если заливка была безцветная, то ColorIndex = xlNone
        'значит выставляем безцветность
        If Not vOldVals(li).lColorIndex = xlNone Then
            Range(vOldVals(li).sAddr).Interior.Color = vOldVals(li).lColor
        Else 'если цвет был - возвращаем его
            Range(vOldVals(li).sAddr).Interior.ColorIndex = xlNone
        End If
    Next li
    Exit Sub
 
    'Показываем сообщение о невозможности отмены действия
Erreble:
    MsgBox "Нельзя отменить действие!", vbCritical, "Error"
End Sub

'Переменные для запоминания данных
Public wbWBook As Workbook
Public wsSh As Worksheet, wsActSh As Worksheet, sSh_Name As String, lShPoz As Long
'---------------------------------------------------------------------------------------
' Procedure : Fill_Numbers
' Purpose   : Основная процедура. Это тот код, который вносит изменения на лист
'             и действия которого нам необходимо отменить
'             Процедура заполняет выделенные ячейки номерами
'             и изменяет цвет заливки
'---------------------------------------------------------------------------------------
Sub Fill_Numbers()
    Dim rCell As Range, li As Long
    'Запоминаем активную книгу
    'это на случай, если отмена действий будет производиться из другой книги
    Set wbWBook = ActiveWorkbook
    'Запоминаем активный лист
    'на случай, если отмена действий будет производиться из другого листа
    Set wsActSh = ActiveSheet
    lShPoz = wsActSh.Index
    sSh_Name = wsActSh.Name
    Application.ScreenUpdating = 0
    wsActSh.Copy , wbWBook.Sheets(wbWBook.Sheets.Count)
    Set wsSh = wbWBook.Sheets(wbWBook.Sheets.Count)
    wsSh.Visible = xlVeryHidden
    wsActSh.Activate
    Application.ScreenUpdating = 1
    '======================================
    'Выполняем основные действия(собственно тот код, который надо будет отменить)
    li = 1
    For Each rCell In Selection
        rCell = li
        rCell.Interior.ColorIndex = li
        li = li + 1
    Next rCell
    '======================================
    'Назначаем стандартному вызову отмены действий выполнение нашего макроса возвращения значений
    Application.OnUndo "Отменить заполнение ячеек номерами", "Restore_Vals"
End Sub
 
'---------------------------------------------------------------------------------------
' Procedure : Restore_Vals
' Purpose   : Процедура отмены действия(возврат значений)
'---------------------------------------------------------------------------------------
Sub Restore_Vals()
    'В случае непредвиденной ошибки переходим на метку
    'и показываем сообщение об ошибке
    On Error GoTo Erreble
    Application.ScreenUpdating = 0
    'Активируем книгу, в которой были сделаны изменения
    wbWBook.Activate
    'делаем видимым резервный лист
    wsSh.Visible = -1
    'Удаляем исходный лист, данные в котором уже изменены
    Application.DisplayAlerts = 0
    wsActSh.Delete
    Application.DisplayAlerts = 1
    'назначаем резервному листу имя исходного
    wsSh.Name = sSh_Name
    wsSh.Move wbWBook.Sheets(lShPoz)
    'Активируем резервный лист
    wsSh.Activate
    Application.ScreenUpdating = 0
    Exit Sub
    'Показываем сообщение о невозможности отмены действия
Erreble:
    MsgBox "Нельзя отменить действие!", vbCritical, "www.excel-vba.ru"
End Sub

RoMuLX

Пользователь

Сообщений: 8
Регистрация: 16.06.2017

Private Sub Workbook_Open() 

For Each sh In ActiveWorkbook.Worksheets 'отображаем все листы 
   sh.Visible = True 
Next sh 
Worksheets("Предупреждение").Visible = xlSheetVeryHidden  'скрываем лист ПРЕДУПРЕЖДЕНИЕ 

Worksheets("Реестр изменений").Rows("2:2").Insert Shift:=xlDown 'вставляем между строками 1 и 2 новую строку 
Worksheets("Реестр изменений").Rows("1001:1001").Delete Shift:=xlUp 'удаляем строку 1001 (реестр на 1000 строк) 
Worksheets("Реестр изменений").Cells(2, 1) = Environ("USERNAME") 'запись в первую ячейку второй строки 
Worksheets("Реестр изменений").Cells(2, 2) = Now 'запись во вторую ячейку второй строки 
ActiveWorkbook.Save 

End Sub 

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) 

Worksheets("Реестр изменений").Rows("2:2").Insert Shift:=xlDown 'вставляем между строками 1 и 2 новую строку 
Worksheets("Реестр изменений").Rows("1001:1001").Delete Shift:=xlUp 'удаляем строку 1001 (реестр на 1000 строк) 
Worksheets("Реестр изменений").Cells(2, 1) = Environ("USERNAME") 'запись в первую ячейку второй строки 
Worksheets("Реестр изменений").Cells(2, 3) = Now 'запись в третью ячейку второй строки 
  
End Sub 

Private Sub Workbook_BeforeClose(Cancel As Boolean) 
    
   If Not Me.Saved Then 

       fmQueryClose.Show 

       Select Case fmQueryClose.DialogResult 
           Case VbMsgBoxResult.vbYes: Me.Save 
               Worksheets("Предупреждение").Visible = True 'скрываем все листы, кроме листа ПРЕДУПРЕЖДЕНИЕ 
               For Each sh In ActiveWorkbook.Worksheets 
                   If sh.Name = "Предупреждение" Then 
                       sh.Visible = True 
                   Else 
                       sh.Visible = xlSheetVeryHidden 
                   End If 
               Next sh 
               ActiveWorkbook.Save 
           Case VbMsgBoxResult.vbNo: Me.Saved = True 
                
>>>> Тут как раз и нужен код на откат всех изменений <<<< 

               Worksheets("Предупреждение").Visible = True 'скрываем все листы, кроме листа ПРЕДУПРЕЖДЕНИЕ 
               For Each sh In ActiveWorkbook.Worksheets 
                   If sh.Name = "Предупреждение" Then 
                       sh.Visible = True 
                   Else 
                       sh.Visible = xlSheetVeryHidden 
                   End If 
               Next sh 
               ActiveWorkbook.Save 

           Case VbMsgBoxResult.vbCancel: Cancel = True 
            
       End Select 
       Unload fmQueryClose 
   End If 
End Sub 

Изменено: RoMuLX — 17.06.2017 13:18:13

Dim undoCount
...
undoCount = 0
...
If checkbox1.value = True Then
    Selection.typeText "text1"
    undoCount = undoCount + 1
Else
    Selection.typeText "text2"
    Selection.typeText "text3"
    undoCount = undoCount + 2
End If
...
For i=1 to undoCount
    ActiveDocument.Undo
Next

6