How to allow multiple successive undos in excel vba? - excel

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

Related

Delete checkbox from a Specific Cell with VBA

I'm putting together a spreadsheet that should populate checkboxes in a specific column when the spreadsheet opens if the appropriate A Column/Row is not empty. It should also remove checkboxes when it finds that same A column to be empty. My VB is correctly creating the checkboxes, but I cannot figure out how to tell the code to delete the checkbox from a specific cell.
Most articles I find mention removed ALL checkboxes, but I'm looking to do it conditionally. Any guidance would be greatly appreciated.
Private Sub Workbook_Open()
'declare a variable
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
'calculate if a cell is not blank across a range of cells with a For Loop
For x = 2 To 1000
If ws.Cells(x, 1) <> "" Then
Call Add_CheckBox(CInt(x))
Else
Call Delete_CheckBox(CInt(x))
End If
Next x
End Sub
Private Sub Add_CheckBox(Row As Integer)
ActiveSheet.CheckBoxes.Add(Cells(Row, "T").Left, Cells(Row, "T").Top, 72, 12.75).Select
With Selection
.Caption = ""
.Value = xlOff '
.LinkedCell = "AA" & Row
.Display3DShading = False
End With
End Sub
Private Sub Delete_CheckBox(Row As Integer)
Dim cb As CheckBox
If cb.TopLeftCell.Address = (Row, "T") Then cb.Delete
End Sub
Naming the CheckBoxes will make it easier to maintain your code.
Private Sub Workbook_Open()
Const CheckBoxPrefix As String = "Sheet1TColumnCheckBox"
'declare a variable
Dim CheckBoxName As String
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
'calculate if a cell is not blank across a range of cells with a For Loop
Dim r As Long
For r = 2 To 1000
CheckBoxName = CheckBoxPrefix & r
If Len(ws.Cells(r, 1)) > 0 Then
If Not WorksheetContainsCheckBox(CheckBoxName, ws) Then Add_CheckBox CheckBoxName, ws.Cells(r, 1), ws.Cells(r, "AA")
Else
If WorksheetContainsCheckBox(CheckBoxName, ws) Then ws.CheckBoxes(CheckBoxName).Delete
End If
Next
End Sub
Private Sub Add_CheckBox(CheckBoxName As String, Cell As Range, LinkedCell As Range)
With Cell.Worksheet.CheckBoxes.Add(Cell.Left, Cell.Top, 72, 12.75)
.Caption = ""
.Value = xlOff '
.LinkedCell = LinkedCell
.Display3DShading = False
.Name = CheckBoxName
End With
End Sub
Function WorksheetContainsCheckBox(CheckBoxName As String, ws As Worksheet)
Dim CheckBox As Object
On Error Resume Next
Set CheckBox = ws.CheckBoxes(CheckBoxName)
WorksheetContainsCheckBox = Err.Number = 0
On Error GoTo 0
End Function
Try something like this (put a checkbox "in" A1 but not C1)
Sub tester()
Debug.Print Delete_CheckBox([A1])
Debug.Print Delete_CheckBox([C1])
End Sub
'Return True if able to delete a checkbox from range `rng`
Private Function Delete_CheckBox(rng As Range) As Boolean
Dim cb As CheckBox
For Each cb In rng.Worksheet.CheckBoxes
If Not Application.Intersect(cb.TopLeftCell, rng) Is Nothing Then
Debug.Print "Deleting checkbox in " & cb.TopLeftCell.Address
cb.Delete
Delete_CheckBox = True
Exit For 'if only expecting one matched checkbox
End If
Next cb
End Function

VBA how to Create Multi Select ListBoxes in qualifying cells

I am trying to achieve code where multi-select ListBoxes are added if Column 4 or 5 are selected and Column 2 in the same row has the string "has options".
The Listboxes contain values from named ranges called "option1" and "option2". Current Selections are output to the respective cell in Column 4 or 5 separated by commas.
This is the code I have in "This Workbook" object. It needs to work on all sheets.
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column = 4 And Target.OFFSET(0, -1).Value = "has options" Then
CreateOpt1PopUp Target
End If
If Target.Column = 5 And Target.OFFSET(0, -2).Value = "has options" Then
CreateOpt2PopUp Target
End If
Else
DeleteAllOpt1PopUps Target
DeleteAllOpt2PopUps Target
End If
End If
End Sub
This is the code I have in a Module. The criteria has evolved and therefore I have amended the code multiple times to the point where it no longer works.
Private opt1SelectCell As Range
Public Function Opt1Area(ByRef ws As Worksheet) As Range
Const OPT1_COL As Long = 4
Dim lastOpt1Row As Long
With ws
lastOpt1Row = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
If lastOpt1Row = 0 Then
Set Opt1Area = Nothing
Else
Set Opt1Area = .Cells(2, OPT1_COL).Resize(lastOpt1Row, 1)
End If
End With
End Function
Public Sub Opt1BoxClick()
Dim opt1BoxName As String
opt1BoxName = Application.Caller
Dim opt1Box As ListBox
Set opt1Box = ActiveSheet.ListBoxes(opt1BoxName)
Dim opt1List As String
Dim i As Long
For i = 1 To opt1Box.ListCount
If opt1Box.Selected(i) Then
opt1List = opt1List & opt1Box.List(i) & ","
End If
Next i
If Len(opt1List) > 0 Then
opt1List = Left$(opt1List, Len(opt1List) - 1)
End If
opt1SelectCell.Value = opt1List
End Sub
Public Function Opt1ListArea() As Range
Set Opt1ListArea = ActiveSheet.Range("option1")
End Function
Public Sub DeleteAllOpt1PopUps(ByRef selectedCell As Range)
Dim opt1Box As ListBox
For Each opt1Box In selectedCell.Parent.ListBoxes
opt1Box.Delete
Next opt1Box
End Sub
Public Sub CreateOpt1PopUp(ByRef selectedCell As Range)
Set opt1SelectCell = selectedCell
Dim Opt1PopUpCell As Range
Set Opt1PopUpCell = opt1SelectCell.OFFSET(1, 0)
DeleteAllOpt1PopUps selectedCell
'--- now create listbox
Const OPT1_POPUP_WIDTH As Double = 75
Const OPT1_POPUP_HEIGHT As Double = 110
Const OPT1_OFFSET As Double = 5#
Dim opt1Box As ListBox
Set opt1Box = ActiveSheet.ListBoxes.Add(Opt1PopUpCell.Left + OPT1_OFFSET, _
Opt1PopUpCell.Top + OPT1_OFFSET, _
OPT1_POPUP_WIDTH, _
OPT1_POPUP_HEIGHT)
With opt1Box
.ListFillRange = Opt1ListArea().Address(external:=True)
.LinkedCell = ""
.MultiSelect = xlSimple
.Display3DShading = True
.OnAction = "Module1.Opt1BoxClick"
End With
'--- is there an existing list of options selected?
Dim selectedOptions1() As String
selectedOptions1 = Split(opt1SelectCell.Value, ",")
Dim opt1 As Variant
For Each opt1 In selectedOptions1
Dim i As Long
For i = 1 To opt1Box.ListCount
If opt1Box.List(i) = opt1 Then
opt1Box.Selected(i) = True
Exit For
End If
Next i
Next opt1
End Sub
This is an example of the excel data.
How can I make this work and even improve it?

VBA sub not entering functions

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.

How to continue the sequence of the unique numbers in the excel sheet after closing the userform?

I am facing a problem in getting the sequence of the unique numbers(Serial number) when the userform is closed and opened later on. Firstly, when I fill the data in the userform everything is captured in the excel sheet perfectly with correct sequence; if I close the userform and run the code by filling the userform with new data the unique ID's are again starting from "1" but not according to the excel sheet row number which was previously saved.
Below is the code I tried:
Private Sub cmdSubmit_Click()
Dim WB As Workbook
Dim lr As Long
Set WB = Workbooks.Open("C:\Users\Desktop\Book2.xlsx")
Dim Database As Worksheet
Set Database = WB.Worksheets("Sheet1")
eRow = Database.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
lr = Database.Range("a65536").End(xlUp).Row
With Sheets("Sheet1")
If IsEmpty(.Range("A1")) Then
.Range("A1").Value = 0
Else
Database.Cells(lr + 1, 1) = Val(Database.Cells(lr, 1)) + 1
End If
End With
Database.Cells(eRow, 4).Value = cmbls.Text
Database.Cells(eRow, 2).Value = txtProject.Text
Database.Cells(eRow, 3).Value = txtEovia.Text
Database.Cells(eRow, 1).Value = txtUid.Text
Call UserForm_Initialize
WB.SaveAs ("C:\Users\Desktop\Book2.xlsx")
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim maxNumber
If Not Intersect(Target, Range("B:B")) Is Nothing Then
' don't run when more than one row is changed
If Target.Rows.Count > 1 Then Exit Sub
' if column A in the current row has a value, don't run
If Cells(Target.Row, 1) > 0 Then Exit Sub
' get the highest number in column A, then add 1 and write to the
' current row, column A
maxNumber = Application.WorksheetFunction.Max(Range("A:A"))
Target.Offset(0, -1) = maxNumber + 1
End If
End Sub
Private Sub UserForm_Initialize()
With txtUid
.Value = Format(Val(Cells(Rows.Count, 1).End(xlUp)) + 1, "0000")
.Enabled = False
End With
With txtProject
.Value = ""
.SetFocus
End With
End Sub
In this image if you see unique id's are repeating 1 and 2, but I need as 1,2,3,4....
I think this is where the issue is coming from. You need to re-calculate the last row every time the user form is Initialized.
Private Sub UserForm_Initialize()
Dim ws as Worksheet: Set ws = Thisworkbook.Sheets("Database")
With txtUid
.Value = Format(ws.Range("A" & ws.Rows.Count).End(xlUp) + 1, "0000")
.Enabled = False
End With
With txtProject
.Value = ""
.SetFocus
End With
End Sub
It's always risky to use row numbers or [max range value +1] as a sequence number.
Safer to use something like a name scoped to the worksheet, which has a value you can increment. Then the sequence is independent of your data.
E.g.
Function GetNextSequence(sht As Worksheet) As Long
Const SEQ_NAME As String = "SEQ"
Dim nm As Name, rv As Long
On Error Resume Next
Set nm = sht.Names(SEQ_NAME)
On Error GoTo 0
'add the name if it doesn't exist
If nm Is Nothing Then
Set nm = sht.Names.Add(Name:=SEQ_NAME, RefersToR1C1:="=0")
End If
rv = Evaluate(nm.Value) + 1
nm.Value = rv
GetNextSequence = rv
End Function

Remove a leading space from a range

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

Resources