' http://www.excel-vba.ru/chto-umeet-excel/kak-otmenit-dejstviya-makrosa/ ' Создаем свой пользовательский тип данных Type SaveRange sAddr As String cellHorizontalAlignment As Long cellVerticalAlignment As Long cellWrapText As Boolean cellOrientation As Long cellAddIndent As Boolean cellIndentLevel As Long cellShrinkToFit As Boolean cellReadingOrder As Long cellMergeCells As Boolean InteriorPattern As Long InteriorColorIndex As Long InteriorPatternColorIndex As Long InteriorThemeColor As Long InteriorTintAndShade As Double InteriorPatternTintAndShade As Double FontName As String FontSize As Double FontStrikethrough As Boolean FontSuperscript As Boolean FontSubscript As Boolean FontOutlineFont As Boolean FontShadow As Boolean FontUnderline As Long FontThemeColor As Long FontTintAndShade As Double FontThemeFont As Long BordersxlEdgeLeftLineStyle As Long BordersxlEdgeLeftColorIndex As Long BordersxlEdgeLeftTintAndShade As Double BordersxlEdgeLeftWeight As Long BordersxlEdgeTopLineStyle As Long BordersxlEdgeTopColorIndex As Long BordersxlEdgeTopTintAndShade As Double BordersxlEdgeTopWeight As Long BordersxlEdgeBottomLineStyle As Long BordersxlEdgeBottomColorIndex As Long BordersxlEdgeBottomTintAndShade As Double BordersxlEdgeBottomWeight As Long BordersxlEdgeRightLineStyle As Long BordersxlEdgeRightColorIndex As Long BordersxlEdgeRightTintAndShade As Double BordersxlEdgeRightWeight As Long BordersxlInsideVerticalLineStyle As Long BordersxlInsideVerticalColorIndex As Long BordersxlInsideVerticalTintAndShade As Double BordersxlInsideVerticalWeight As Long BordersxlInsideHorizontalLineStyle As Long BordersxlInsideHorizontalColorIndex As Long BordersxlInsideHorizontalTintAndShade As Double BordersxlInsideHorizontalWeight As Long End Type 'Переменные для запоминания данных Public wbWBook As Workbook Public wsSh As Worksheet Public vOldVals() As SaveRange Public myPPTRange As Range ' Порог количества ячеек для сохранения истории действий Const cMaxSelCells As Integer = 100 '------------------------------ ' http://engineerbox.ru/page/excel-format-po-obrazcu-dlja-neskolkih-jacheek ' by Colee ' 30.07.2016 '------------------------------ Sub ЯчейкиПоФормату() SaveRange On Error Resume Next Set sCell = Application.InputBox("Select One cell", Type:=8) If TypeName(sCell) <> "Range" Then Exit Sub sCell.Copy Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False 'Назначаем стандартному вызову отмены действий выполнение нашего макроса возвращения значений If Not wbWBook Is Nothing Then Application.OnUndo "Отменить копирование формата", "Restore_Vals" End Sub Private Sub SaveRange() Dim rCell As Range, saveCell As Range, li As Long ' Сначала запоминаем значения выделенных ячеек на листе If Selection.Count > cMaxSelCells Then Exit Sub ReDim vOldVals(1 To Selection.Count) Prepare 'Запоминаем активную книгу 'это на случай, если отмена действий будет производиться из другой книги Set wbWBook = ActiveWorkbook 'Запоминаем активный лист 'на случай, если отмена действий будет производиться из другого листа Set wsSh = ActiveSheet 'Запоминаем значения(заносим в массив) li = 1 For Each rCell In Selection 'запоминаем адрес ячейки vOldVals(li).sAddr = rCell.Address CopyCellProp rCell, vOldVals(li) CopyFontProp rCell, vOldVals(li) CopyColorProp rCell, vOldVals(li) CopyFontProp rCell, vOldVals(li) CopyBordersProp rCell, vOldVals(li) li = li + 1 Next rCell Ended End Sub '--------------------------------------------------------------------------------------- ' Procedure : Restore_Vals ' Purpose : Процедура отмены действия(возврат значений) '--------------------------------------------------------------------------------------- Private Sub Restore_Vals() Dim li As Long 'В случае непредвиденной ошибки переходим на метку 'и показываем сообщение об ошибке 'Debug.Print IsEmpty(vOldVals) Prepare On Error GoTo Erreble 'Активируем книгу, в которой были сделаны изменения wbWBook.Activate 'Активируем лист, в котором были сделаны изменения wsSh.Activate 'Возвращаем значения For li = 1 To UBound(vOldVals) GetCellProp Range(vOldVals(li).sAddr), vOldVals(li) GetFontProp Range(vOldVals(li).sAddr), vOldVals(li) GetBordersProp Range(vOldVals(li).sAddr), vOldVals(li) GetColorProp Range(vOldVals(li).sAddr), vOldVals(li) Next li Ended 'MsgBox "Действие отменено!", vbOK, "Processing" Exit Sub 'Показываем сообщение о невозможности отмены действия Erreble: Ended MsgBox "Нельзя отменить действие!", vbCritical, "Error" End Sub Sub CopyCellProp(cell_in As Range, cell_out As SaveRange) With cell_in cell_out.cellHorizontalAlignment = .HorizontalAlignment cell_out.cellVerticalAlignment = .VerticalAlignment cell_out.cellWrapText = .WrapText cell_out.cellOrientation = .Orientation cell_out.cellAddIndent = .AddIndent cell_out.cellIndentLevel = .IndentLevel cell_out.cellShrinkToFit = .ShrinkToFit cell_out.cellReadingOrder = .ReadingOrder cell_out.cellMergeCells = .MergeCells End With End Sub Sub GetCellProp(cell_in As Range, cell_out As SaveRange) On Error Resume Next With cell_in .HorizontalAlignment = cell_out.cellHorizontalAlignment .VerticalAlignment = cell_out.cellVerticalAlignment .WrapText = cell_out.cellWrapText .Orientation = cell_out.cellOrientation .AddIndent = cell_out.cellAddIndent .IndentLevel = cell_out.cellIndentLevel .ShrinkToFit = cell_out.cellShrinkToFit .ReadingOrder = cell_out.cellReadingOrder .MergeCells = cell_out.cellMergeCells End With End Sub Sub CopyBordersProp(cell_in As Range, cell_out As SaveRange) 'On Error Resume Next With cell_in.Borders(xlEdgeLeft) cell_out.BordersxlEdgeLeftLineStyle = .LineStyle cell_out.BordersxlEdgeLeftColorIndex = .ColorIndex If Not IsNull(.TintAndShade) Then cell_out.BordersxlEdgeLeftTintAndShade = .TintAndShade cell_out.BordersxlEdgeLeftWeight = .Weight End With With cell_in.Borders(xlEdgeTop) cell_out.BordersxlEdgeTopLineStyle = .LineStyle cell_out.BordersxlEdgeTopColorIndex = .ColorIndex If Not IsNull(.TintAndShade) Then cell_out.BordersxlEdgeTopTintAndShade = .TintAndShade cell_out.BordersxlEdgeTopWeight = .Weight End With With cell_in.Borders(xlEdgeBottom) cell_out.BordersxlEdgeBottomLineStyle = .LineStyle cell_out.BordersxlEdgeBottomColorIndex = .ColorIndex If Not IsNull(.TintAndShade) Then cell_out.BordersxlEdgeBottomTintAndShade = .TintAndShade cell_out.BordersxlEdgeBottomWeight = .Weight End With With cell_in.Borders(xlEdgeRight) cell_out.BordersxlEdgeRightLineStyle = .LineStyle cell_out.BordersxlEdgeRightColorIndex = .ColorIndex If Not IsNull(.TintAndShade) Then cell_out.BordersxlEdgeRightTintAndShade = .TintAndShade cell_out.BordersxlEdgeRightWeight = .Weight End With With cell_in.Borders(xlInsideVertical) cell_out.BordersxlInsideVerticalLineStyle = .LineStyle cell_out.BordersxlInsideVerticalColorIndex = .ColorIndex If Not IsNull(.TintAndShade) Then cell_out.BordersxlInsideVerticalTintAndShade = .TintAndShade cell_out.BordersxlInsideVerticalWeight = .Weight End With With cell_in.Borders(xlInsideHorizontal) cell_out.BordersxlInsideHorizontalLineStyle = .LineStyle cell_out.BordersxlInsideHorizontalColorIndex = .ColorIndex If Not IsNull(.TintAndShade) Then cell_out.BordersxlInsideHorizontalTintAndShade = .TintAndShade cell_out.BordersxlInsideHorizontalWeight = .Weight End With End Sub Sub GetBordersProp(cell_in As Range, cell_out As SaveRange) 'On Error Resume Next With cell_in.Borders(xlEdgeLeft) .ColorIndex = cell_out.BordersxlEdgeLeftColorIndex .TintAndShade = cell_out.BordersxlEdgeLeftTintAndShade .Weight = cell_out.BordersxlEdgeLeftWeight .LineStyle = cell_out.BordersxlEdgeLeftLineStyle End With With cell_in.Borders(xlEdgeTop) .ColorIndex = cell_out.BordersxlEdgeTopColorIndex .TintAndShade = cell_out.BordersxlEdgeTopTintAndShade .Weight = cell_out.BordersxlEdgeTopWeight .LineStyle = cell_out.BordersxlEdgeTopLineStyle End With With cell_in.Borders(xlEdgeBottom) .ColorIndex = cell_out.BordersxlEdgeBottomColorIndex .TintAndShade = cell_out.BordersxlEdgeBottomTintAndShade .Weight = cell_out.BordersxlEdgeBottomWeight .LineStyle = cell_out.BordersxlEdgeBottomLineStyle End With With cell_in.Borders(xlEdgeRight) .ColorIndex = cell_out.BordersxlEdgeRightColorIndex .TintAndShade = cell_out.BordersxlEdgeRightTintAndShade .Weight = cell_out.BordersxlEdgeRightWeight .LineStyle = cell_out.BordersxlEdgeRightLineStyle End With With cell_in.Borders(xlInsideVertical) .ColorIndex = cell_out.BordersxlInsideVerticalColorIndex .TintAndShade = cell_out.BordersxlInsideVerticalTintAndShade .Weight = cell_out.BordersxlInsideVerticalWeight .LineStyle = cell_out.BordersxlInsideVerticalLineStyle End With With cell_in.Borders(xlInsideHorizontal) .ColorIndex = cell_out.BordersxlInsideHorizontalColorIndex .TintAndShade = cell_out.BordersxlInsideHorizontalTintAndShade .Weight = cell_out.BordersxlInsideHorizontalWeight .LineStyle = cell_out.BordersxlInsideHorizontalLineStyle End With End Sub Sub CopyFontProp(cell_in As Range, cell_out As SaveRange) With cell_in.Font cell_out.FontName = .Name cell_out.FontSize = .Size cell_out.FontStrikethrough = .Strikethrough cell_out.FontSuperscript = .Superscript cell_out.FontSubscript = .Subscript cell_out.FontOutlineFont = .OutlineFont cell_out.FontShadow = .Shadow cell_out.FontUnderline = .Underline cell_out.FontThemeColor = .ThemeColor cell_out.FontTintAndShade = .TintAndShade cell_out.FontThemeFont = .ThemeFont End With End Sub Sub GetFontProp(cell_in As Range, cell_out As SaveRange) On Error Resume Next With cell_in.Font .Name = cell_out.FontName .Size = cell_out.FontSize .Strikethrough = cell_out.FontStrikethrough .Superscript = cell_out.FontSuperscript .Subscript = cell_out.FontSubscript .OutlineFont = cell_out.FontOutlineFont .Shadow = cell_out.FontShadow .Underline = cell_out.FontUnderline .ThemeColor = cell_out.FontThemeColor .TintAndShade = cell_out.FontTintAndShade .ThemeFont = cell_out.FontThemeFont End With End Sub Sub CopyColorProp(cell_in As Range, cell_out As SaveRange) 'On Error Resume Next With cell_in.Interior cell_out.InteriorPattern = .Pattern cell_out.InteriorColorIndex = .ColorIndex cell_out.InteriorPatternColorIndex = .PatternColorIndex cell_out.InteriorThemeColor = .ThemeColor cell_out.InteriorTintAndShade = .TintAndShade cell_out.InteriorPatternTintAndShade = .PatternTintAndShade End With End Sub Sub GetColorProp(cell_in As Range, cell_out As SaveRange) On Error Resume Next With cell_in.Interior .Pattern = cell_out.InteriorPattern .ColorIndex = cell_out.InteriorColorIndex .ThemeColor = cell_out.InteriorThemeColor .PatternColorIndex = cell_out.InteriorPatternColorIndex .TintAndShade = cell_out.InteriorTintAndShade .PatternTintAndShade = cell_out.InteriorPatternTintAndShade End With End Sub ' https://geektimes.ru/post/112458/ Private Sub Prepare() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False ActiveSheet.DisplayPageBreaks = False Application.DisplayStatusBar = False Application.DisplayAlerts = False End Sub Private Sub Ended() Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True ActiveSheet.DisplayPageBreaks = True Application.DisplayStatusBar = True Application.DisplayAlerts = True End Sub