K
ktoth04
So I found the following code from 1999, that some guy posted as having
trouble with in 2006, that should, SUPPOSEDLY, restore the undo queue. Now,
It doesn't work, and i'm not sure why, because it is way beyond my level of
understanding. Can anyone let me know if the idea is sound (even if you
can't tell me what is wrong with it)? I don't want to spend 20 hours trying
to fix it and then have it not work -_-
I commented out some lines that seemed to be comments, and one at the end
(3rd from bottom) where I am not sure what is up, but VBA didn't like it.
'############# HERE IS THE MODUL #################
'############# START OF VBA CLASS MODUL ##########
Option Explicit
' ***** Public functions
' SetUndo(ByVal obj As Object, ByVal rng As Range)
' GetUndo()
''' ******************************************************
'''
''' Modul's private declarations
'''
''' ******************************************************
Private Type typUndo ' new undo type - OLD CELL
address As String ' address of the cell
value As Variant ' value of the cell
End Type
Private Type typUndoLevel
size As Integer ' size of undo level
data() As typUndo ' undo data
End Type
Dim undoLevel As Integer ' level of undo information
Dim UnDo() As typUndoLevel ' whole undo information
''' ******************************************************
'''
''' P U B L I C F U N C T I O N S / P R E C E D U R E S
'''
''' ******************************************************
'''
'''
''' Procedure : SetUndo
''' Description : Copy range data to undoData (old values)
''' Return value: None
''' Arguments : rng : range with data
''' reset : if true than undolevel is reset to 1
''' Created : Matjaz Prtenjak, 11/10/1999
'''
Public Sub SetUndo(ByVal rng As Range, Optional reset As Boolean = False)
Dim cell
Dim counter As Long
' set level
If reset Then
undoLevel = 1
ReDim UnDo(undoLevel)
Else
undoLevel = undoLevel + 1
End If
' set tables
ReDim Preserve UnDo(undoLevel)
With UnDo(undoLevel)
.size = rng.Cells.Count
ReDim Preserve .data(.size)
counter = 1
For Each cell In rng.Cells
With .data(counter)
.address = cell.address(External:=True)
.value = cell.Formula
End With
counter = counter + 1
Next
End With
End Sub
'''
'''
''' Procedure : GetUndo
''' Description : Put the old values, previous saved by SetUndo in place
''' Return value: None
''' Arguments : None
''' Created : Matjaz Prtenjak, 11/10/1999
'''
Public Sub GetUndo()
On Error GoTo quit
Dim i As Long
If undoLevel = 0 Then Exit Sub
Application.ScreenUpdating = False
With UnDo(undoLevel)
For i = 1 To .size
Range(.data(i).address).Formula = .data(i).value
If i Mod 1000 = 0 Then DoEvents
Next
End With
' reset level
If undoLevel > 1 Then
undoLevel = undoLevel - 1
ReDim Preserve UnDo(undoLevel)
End If
quit:
Application.ScreenUpdating = True
End Sub
Private Sub Class_Initialize()
undoLevel = 0
End Sub
Private Sub Class_Terminate()
ReDim UnDo(1)
End Sub
'############# START OF VBA CLASS MODUL ##########
'############# USE ##########
Dim UnDo As New clsUndo
'.........
Set UnDo = New clsUndo
'.........
UnDo.SetUndo myRange
UnDo.SetUndo Selection
'UnDo.SetUndo .....
UnDo.GetUndo
UnDo.GetUndo
trouble with in 2006, that should, SUPPOSEDLY, restore the undo queue. Now,
It doesn't work, and i'm not sure why, because it is way beyond my level of
understanding. Can anyone let me know if the idea is sound (even if you
can't tell me what is wrong with it)? I don't want to spend 20 hours trying
to fix it and then have it not work -_-
I commented out some lines that seemed to be comments, and one at the end
(3rd from bottom) where I am not sure what is up, but VBA didn't like it.
'############# HERE IS THE MODUL #################
'############# START OF VBA CLASS MODUL ##########
Option Explicit
' ***** Public functions
' SetUndo(ByVal obj As Object, ByVal rng As Range)
' GetUndo()
''' ******************************************************
'''
''' Modul's private declarations
'''
''' ******************************************************
Private Type typUndo ' new undo type - OLD CELL
address As String ' address of the cell
value As Variant ' value of the cell
End Type
Private Type typUndoLevel
size As Integer ' size of undo level
data() As typUndo ' undo data
End Type
Dim undoLevel As Integer ' level of undo information
Dim UnDo() As typUndoLevel ' whole undo information
''' ******************************************************
'''
''' P U B L I C F U N C T I O N S / P R E C E D U R E S
'''
''' ******************************************************
'''
'''
''' Procedure : SetUndo
''' Description : Copy range data to undoData (old values)
''' Return value: None
''' Arguments : rng : range with data
''' reset : if true than undolevel is reset to 1
''' Created : Matjaz Prtenjak, 11/10/1999
'''
Public Sub SetUndo(ByVal rng As Range, Optional reset As Boolean = False)
Dim cell
Dim counter As Long
' set level
If reset Then
undoLevel = 1
ReDim UnDo(undoLevel)
Else
undoLevel = undoLevel + 1
End If
' set tables
ReDim Preserve UnDo(undoLevel)
With UnDo(undoLevel)
.size = rng.Cells.Count
ReDim Preserve .data(.size)
counter = 1
For Each cell In rng.Cells
With .data(counter)
.address = cell.address(External:=True)
.value = cell.Formula
End With
counter = counter + 1
Next
End With
End Sub
'''
'''
''' Procedure : GetUndo
''' Description : Put the old values, previous saved by SetUndo in place
''' Return value: None
''' Arguments : None
''' Created : Matjaz Prtenjak, 11/10/1999
'''
Public Sub GetUndo()
On Error GoTo quit
Dim i As Long
If undoLevel = 0 Then Exit Sub
Application.ScreenUpdating = False
With UnDo(undoLevel)
For i = 1 To .size
Range(.data(i).address).Formula = .data(i).value
If i Mod 1000 = 0 Then DoEvents
Next
End With
' reset level
If undoLevel > 1 Then
undoLevel = undoLevel - 1
ReDim Preserve UnDo(undoLevel)
End If
quit:
Application.ScreenUpdating = True
End Sub
Private Sub Class_Initialize()
undoLevel = 0
End Sub
Private Sub Class_Terminate()
ReDim UnDo(1)
End Sub
'############# START OF VBA CLASS MODUL ##########
'############# USE ##########
Dim UnDo As New clsUndo
'.........
Set UnDo = New clsUndo
'.........
UnDo.SetUndo myRange
UnDo.SetUndo Selection
'UnDo.SetUndo .....
UnDo.GetUndo
UnDo.GetUndo