This question already has answers here:
Detect if range is empty
(8 answers)
Closed 2 years ago.
Is there any way to shorten down this line with a better range statement? When one cell out of the range ("C3:I3") is empty I need it to produce a MsgBox, else run the rest of the code.
If IsEmpty(Range("C3")) = True Or IsEmpty(Range("D3")) = True Or IsEmpty(Range("E3")) = True Or IsEmpty(Range("F3")) = True Or IsEmpty(Range("G3")) = True Or IsEmpty(Range("H3")) = True Or IsEmpty(Range("I3")) = True Then
When I use If IsEmpty(Range("C3:I3")) = True Then the code behaves differently and does not work when only one cell is empty.
Try this:
Function IsRangeEmpty(ByRef theRange As Range) As Boolean
Dim c As Range
For Each c In theRange
If Not IsEmpty(c) Then
IsRangeEmpty = False
Exit Function
End If
Next c
IsRangeEmpty = True
End Function
You could any of the below:
Loop range:
Sub test()
Dim rng As Range, cell As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .Range("C3:C13")
For Each cell In rng
If cell = "" Then
MsgBox "Empty cell!"
End If
Next
End With
End Sub
Pass the range to an array and loop array - Faster:
Sub test_1()
Dim arr As Variant
Dim i As Long
With ThisWorkbook.Worksheets("Sheet1")
arr = .Range("C3:C13")
For i = LBound(arr) To UBound(arr)
If arr(i, 1) = "" Then
MsgBox "Empty cell!"
End If
Next
End With
End Sub
I created the below functions in different sheets in my Excel workbook and they are all executed by a sub. However when I start the sub it doesn't access the functions and directly skips the If statements.
Sheet1 functions:
Public Function ndg(row As Range) As Integer
ndg = Range("b" & row).Value
End Function
Function Checkispraticaforeclosure(row As Range)
Dim ndga As Integer
Dim rowindex As Integer
ndga = ndg(row)
rowindex = Sheet6.findrownumberndg(ndga)
If Sheet6.ispositionforeclosure(rowindex) = True Then
row.Cells(33) = Sheet6.getforeclosurecode(rowindex)
Checkispraticaforeclosure = True
Else
Checkispraticaforeclosure = False
End If
End Function
Sub insertcode(row As Range)
Dim ndga As Integer
Dim rowindex As Integer
ndga = ndg(row)
rowindex = Sheet6.findrownumberndg(ndga)
If Sheet6.ispositionforeclosure(rowindex) = False Then
row.Cells(33) = "ok"
End If
End Sub
Sheet6 functions:
Public Function findrownumberndg(ndg As Integer) As Integer
Set foundcell = Sheet6.Range("a:a").Find(ndg, lookat:=xlWhole)
If Not foundcell Is Nothing Then
findrownumberndg = 0
Else
findrownumberndg = foundcell.row
End If
End Function
Public Function ispositionforeclosure(row As Integer) As Boolean
If Range("D" & row).Value = "Foreclosure procedure" Then
ispositionforeclosure = True
Else
ispositionforeclosure = False
End If
End Function
Public Function getforeclosurecode(row As Integer)
getforeclosurecode = Range("f" & row).Value
End Function
Execute sub:
Public Function sheet1lastrow()
lastrow = Sheet1.Cells(Rows.Count, "b").End(xlUp).row
End Function
Sub masterinsertcode()
For x = 6 To ThisWorkbook.sheet1lastrow()
Dim checked
checked = False
Dim currentrow As Range
Set currentrow = Sheet1.Rows(x)
checked = Sheet1.Checkispraticaforeclosure(currentrow)
If checked = False Then
Sheet1.insertcode (currentrow)
End If
Next
End Sub
I am unsure why the execute sub doesn't enter in the checks I created and directly goes to End Sub.
I would like to select only rows with the value unchecked but I am getting an error due to type mismatch. Please advise
Sub Hide_Rows()
If Range("D3:F100").Value = "Checked" Then
Rows("3:100").EntireRow.Hidden = True
ElseIf Range("D3:F100").Value = "Unchecked" Then
Rows("3:").EntireRow.Hidden = False
End If
End Sub
You cannot test an array of values to one value:
If Range("D3:F100").Value = "Checked" Then
will always error. You need to loop and check each value individually:
This will un-hide the row if any of the values in Columns D,E,F are Unchecked All others will be hidden.
Sub Hide_Rows()
ActiveSheet.Range("3:100").EntireRow.Hidden = True
Dim i As Long
For i = 3 To 100
Dim j As Long
For j = 4 To 6
If ActiveSheet.Cells(i, j) = "Unchecked" Then
Dim UnRng As Range
If UnRng Is Nothing Then
Set UnRng = ActiveSheet.Rows(i)
Else
Set UnRng = Union(UnRng, ActiveSheet.Rows(i))
End If
Exit For
End If
Next j
Next i
UnRng.EntireRow.Hidden = False
End Sub
I have a column range of about 500 rows. Most of those cells are stored as text. I populate a listbox on a userform with the values from that range. When a user selects one of those values from the listbox an event will find the value on the same row from another column using Index and Match and display it in a label on the userform. I get an error when selecting one of the few cells in the listbox that are not stored as text in the range because there is a leading space. I am assuming that the populated listbox automatically removes leading spaces from any cells in the range. Therefore, when it tries to find value 12345 from the listbox, for example, in the range it can't find it because the range contains (space)12345. I have tried:
Public Sub UserForm_Initialize()
Dim arr() As Variant
Dim rNum As Range
Const sNum As String = "Number"
Me.EnableEvents = False
wsName = "Report"
Set curWb = ActiveWorkbook
Set pReport = curWb.Worksheets(wsName)
Set pTable = pReport.ListObjects("tableName")
With pReport
If .AutoFilterMode = True Then .ShowAllData
.Cells.Rows.Hidden = False
.Cells.Columns.Hidden = False
End With
Set wf = Application.WorksheetFunction
With pTable
Set rNum = .ListColumns(.ListColumns(sNum).Range.column).DataBodyRange
End With
-- HERE is where I tried all my implementations without success
arr = wf.Transpose(pReport.Range(rNum.address).Value)
Call BubbleSort(arr)
frmIssues.lstIssues1.List = arr
lstIssues1.ListStyle = 1
lstIssues2.ListStyle = 1
lstIssues1.MultiSelect = 2
lstIssues2.MultiSelect = 2
txtFocus.SetFocus
Me.EnableEvents = True
End Sub
Private Sub lstIssues1_Change()
Dim rNum As Range
Dim rTitle As Range
Dim strResult As String
Dim intIndex As Integer
Dim intCount As Integer
Const sNum As String = "Number"
Const sTitle As String = "Title"
If EnableEvents = False Then Exit Sub
With lstIssues1
For intIndex = 0 To .ListCount - 1
If .Selected(intIndex) Then intCount = intCount + 1
Next
End With
If intCount = 1 Then
Set wf = Application.WorksheetFunction
wsName = "Report"
Set curWb = ActiveWorkbook
Set pReport = curWb.Worksheets(wsName)
Set pTable = pReport.ListObjects("tableName")
With pTable
Set rNum = .ListColumns(.ListColumns(sNum).Range.column).DataBodyRange
Set rTitle = .ListColumns(.ListColumns(sTitle).Range.column).DataBodyRange
End With
With pReport
strResult = wf.Index(.Range(rTitle.address), wf.Match(lstIssues1.List(lstIssues1.ListIndex), .Range(rNum.address), 0))
End With
lblDescription.Caption = wf.Trim(strResult)
txtFocus.SetFocus
Else
lblDescription.Caption = ""
txtFocus.SetFocus
Exit Sub
End If
Me.EnableEvents = False
For i = 0 To lstIssues2.ListCount - 1
If lstIssues2.Selected(i) = True Then lstIssues2.Selected(i) = False
Next
Me.EnableEvents = True
End Sub
and numerous variations of it (Clean, CStr, .Text, etc.) and nothing works. Truly, I have no clue how to fix this and any help whatsoever is much appreciated. Thank you!
Clarification
1) This Excel file is generated from the Web.
2) A Macro turns the Worksheet into a table
3) Left(Range("D362"),1) returns 1 (The number, say, is 12345)
4) Before the error occurs Range("D362") returns (space)12345
5) After the error occurs Range("D362") returns (space)12345
I have just tested this and it works in removing the space at the begining of a string. Sadly it isnt a single line as I (and likely you) would have prefered
Sub test()
Dim CellValue As String
Dim lngNumberOfCharacters As Long
CellValue = ActiveCell.Value
CellValueCheck = Left(CellValue, 1)
If CellValueCheck = " " Then
lngNumberOfCharacters = Len(CellValue) - 1
CellValue = Right(CellValue, lngNumberOfCharacters)
ActiveCell.Value = CellValue
End If
End Sub
Let me know if you need anything confirmed
I have an excel workbook that needs to allow the user to undo multiple changes within a worksheet. I have searched online in every forum that I can think of and have not been able to find an answer for this. I realize that there is an issue with the undo issue in excel when macro's are run, and have been able to handle this using code derived from here.
This is my current process:
Create global variables to hold the initial state of the workbook, and the changes. Code is as follows:
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
Get the initial state of the workbook by building an array (InitialState) holding the values of all the cells in the Workbook_Open sub. Code is as follows:
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
When a value is entered into a cell, store the value entered into another array (OldSelection) holding the value entered. This is done in the Workbook_Change sub. The important parts here are the Call SaveState(OldSelectionCount, Target.Cells.address, Target.Cells.Value) and Application.OnUndo "Undo the last action", "GI.OR.E1664.20150915_DRAFT.xlt!Sheet1.RevertState" pieces which are shown in numbers 4 and 5 below. Code is as follows:
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
The SaveState Sub will save add to the OldSelection array, any values that have changed. Code is as follows:
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
The RevertState Sub will undo ONLY THE LAST ACTION! I am unable to allow more than the last entry to be undone. Code is as follows:
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
Does anyone know of a way to allow multiple undo's to be done?
Any help to solve this issue would be greatly appreciated!
After researching the Undo function on MSDN here, I found that the Application.Undo function only undoes the last action taken by the user. Instead of trying to get Microsoft's undo functionality to work, I have added my own undo and redo buttons which function the same as Microsoft's buttons. I have added two class modules: ActionState (holds the properties for workbook, worksheet, address and value of a cell)
ActionStates (a collection ActionState objects along with functions for adding, removing, getting an item, clearing the collection, counting, and properties for the CurrentState, and InitialState of the worksheet).
The new process is as follows:
Get the initial state of all the cells in the worksheet and add these to the undo stack array (see GetInitialCellStates() method within UndoFuntionality module).
When an item is added to a cell, add the address and value to the array (see SaveState() method within UndoFunctionality module) and update the index of the current state to the most recently added value. Repeat this step with any additional values.
When this is done, it enables the undo button.
If the undo button is pressed, it will decrement the index of the current state and enable the redo button (see RevertState() function within UndoFunctionality module).
If the redo button is pressed it will increment the index of the current state (see ProgressState() function within UndoFunctionality module).
The code for the ActionState class is as follows:
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
The code for the ActionStates class is as follows:
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
These two classes are used in a new module called UndoFunctionality as follows:
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
The GetInitialStates method is used in the workbook_open event as follows:
UndoFunctionality.GetInitialCellStates
And the Worksheet_Change event within the worksheet is as follows:
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
The only thing left is to add two buttons to the worksheet and assign the macro used to the UndoButton_Click() and RedoButton_Click() events which will run the RevertState() and ProgressState() methods.
I found a little trick using Application.OnTime. So it is possible to use Undo repeatedly.
The Repeat button is not the Redo button. You can find it in the Edit menu or put it on your ribbon.
I am using Excel 2003.
Here is a working sample. Put the code inside ThisWorkbook module.
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