VBA BeforeSave check for Missing Data - vba

I'm struggling with some VBA code and the BeforeSave methodology.
I've been all over the forums but can't locate the answer I need, so would love some help please.
My question! On saving I need the code to look at Column H (named Claim USD) of a 'Table' (named Claims) for a number value and then if any of the cells has a value to then look at Column I (named Claim Date) and make sure there is a date in there. I have already data validated column I to only accept date entries.
I have found the code below, and tested it for what it does and it works. I'm just not sure how to incorporate my element. Can anyone offer me some help?
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim rsave As Range
Dim cell As Range
Set rsave = Sheet2.Range("I8,I500")
For Each cell In rsave
If cell = "" Then
Dim missdata
missdata = MsgBox("missing data", vbOKOnly, "Missing Data")
Cancel = True
cell.Select
Exit For
End If
Next cell
End Sub

I have created a custom Class for validation see here. It is very overkill for what you are trying to do but what it will allow you to do is capture all of the cells with errors and do what you'd like with them. You can download and import the 2 class modules Validator.cls and ValidatorErrors.cls And then use the following
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Unflag
Dim rsave As Range
Dim rcell As Range
Dim v AS New Validator
Set rsave = Sheet2.Range("Table1[Estimate Date]")
with v
For Each rcell In rsave
.validates rcell,rcell.address
.presence
Next rcell
End With
If not(v.is_valid) Then
FlagCollection v.errors
MsgBox("Missing data in " & v.unique_keys.Count & " Cell(s).", vbOKOnly, "Missing Data")
Cancel = True
End IF
Set v = Nothing
End Sub
Public Sub flag(flag As String, comment As String)
Dim comments As String
If has_comments(flag) Then
comments = Sheet2.Range(flag).comment.Text & vbNewLine & comment
Else
comments = comment
End If
Sheet2.Range(flag).Interior.Color = RGB(255, 255, 102)
Sheet2.Range(flag).ClearComments
Sheet2.Range(flag).AddComment comments
End Sub
Public Sub FlagCollection(all_cells As Collection)
Dim flag_cell As ValidatorError
For Each flag_cell In all_cells
flag flag_cell.field, flag_cell.error_message
Next flag_cell
End Sub
Public Sub Unflag()
Cells.Select
Selection.Interior.ColorIndex = xlNone
Selection.ClearComments
End Sub
Public Function has_comments(c_cell As String) As Boolean
On Error Resume Next
Sheet1.Range(c_cell).comment.Text
has_comments = Not (CLng(Err.Number) = 91)
End Function
This will flag every field that has an error in yellow and add a comment as to what the issue is you could also determine a way to tell the user exactly where the errors are using v.uniq_keys which returns a collection of cell address' that fail validation of presence.

I'm pretty sure I cracked it, well it works anyway. Code below (for those who are interested anyway!!)
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim rsave As Range
Dim cell As Range
Set rsave = Sheet2.Range("Table1[Estimated Claim (USD)]")
For Each cell In rsave
If cell.Value <> "" And cell.Offset(0, 1).Value = "" Then
Dim missdata
missdata = MsgBox("Missing Data - Enter the Date for WorkBook to Save", vbOKOnly, "Missing Data")
Cancel = True
cell.Offset(0, 1).Select
Exit For
End If
Next cell
End Sub
I've now got to loop this through three other column headers checking for same criteria. If anyone knows a quicker code method. Would appreciate the help!

Related

How to use Public Range value in multiple user forms?

I have a userform which will ask for a number that is then getting looked up in a spreadsheet, saving that range in a variable. When it's found the number, it will hide the first userform and bring up the second one, but in order for me to proceed with the update, I will need to use the same range that I've previously set against my variable in userform1, any idea how to do that? I have declared it as a Public variable but it still doesn't work. Code as it follows:
UserForm1:
Public FillRange As Range
Public BKref As Variant
Private Sub CommandButton1_Click()
On Error GoTo errhndlr:
Set FillRange = Sheets("Loader").Cells.Find(TextRef.Value).Offset(0, 2)
BKref = TextRef.Value
If Not FillRange = "" Then
UserForm1.Hide
UserForm2.Show
Exit Sub
ElseIf FillRange = "" Then
MsgBox "Booking Reference cannot be empty!", vbCritical, "Error: No Booking Ref."
UserForm1.Hide
Exit Sub
Else
MsgBox "Unexpected error, please re-start and try again. If you had this message more than 2 times, please update the line manually.", vbCritical, "Error"
UserForm1.Hide
Exit Sub
End If
Exit Sub
errhndlr:
MsgBox "Booking reference not found, please double-check that the booking reference you've entered is correct, alternatively update it manually.", vbCritical, "Error"
UserFrom1.Hide
End Sub
UserForm2:
Private Sub CommandButton1_Click()
FillRange = TextPloaded.Value
FillRange.Offset(0, 2) = TextTime.Value
FillRange.Offset(0, 3) = TextLoader.Value
If Not TextComm.Value = "" Then
FillRange.Offset(0, 4) = TextComm.Value
ElseIf TextComm.Value = "" Then
FillRange.Offset(0, 4) = ""
End If
If Not FillRange = FillRange(0, -1) Then
MsgBox "Actual and Planned pallets doesn't match, please highlight the diescrepancies on the assembly sheet!"
BKref = FillRange.Offset(0, -2)
Sheets("Assembly").Activate
Sheets("Assembly").Rows(1).AutoFilter Field:=16, Criteria1:=BKref
UserForm2.Hide
Else
UserForm2.Hide
UserForm1.Show
End If
End Sub
If you make use of Option Explicit in every module/userform etc. This forces you to declare all variables properly and shows a message if a variable is not declared.
The issue is that if you declare Public FillRange As Range in Userform1 the variable is only valid in Userform1 but not in Userform2.
So I recommend to decare the variable in a Module instead of Userform1. This way it is accessible everywhere.
Alternative
You can access a public Userform1 variable in Userfrom2 by Userform1.FillRange
Add a property in your first form:
Property Get FillRange() As Range
Set FillRange = Range("A1")
End Property
And read it from your second form:
Dim FillRange
Set FillRange = UserForm1.FillRange

VBA 2 IF conditions applied for column

this is my first post, please be patient if I'm doing/asking something wrong.
My issue is:
I got 2 columns, A is number of children, B is name of those children.
Those values are manually entered, I simply would like to have B mandatory if A is filled.
Here is what I thought:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not IsEmpty(Sheet1.Range("A1")) Then
If IsEmpty(Sheet1.Range("B1")) Then
MsgBox "Please fill in cell B1 before closing."
Cancel = True
Else '
End If
End If
End Sub
This is actually working perfectly, unfortunately I can't manage to extend it for whole columns, when replacing A1 with A1:A1000 and B1 with B1:B1000 for instance,it doesn't work.
How can I validate this for both entire column A and B?
thanks in advance!
Try this
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Cancel = Evaluate("SUMPRODUCT(--(ISBLANK(Sheet1!B:B) <> ISBLANK(Sheet1!A:A)))")
If Cancel Then MsgBox "Please fill in column B before closing."
End Sub
EDIT
In order to take the user to the place where data is missing, and taking into account the additional information you provided about your data, try this:
'Private Sub Workbook_BeforeClose(Cancel As Boolean)
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim r: r = Evaluate( _
"MATCH(FALSE, ISBLANK('ELENCO AGGIORNATO'!V:V) = ISBLANK('ELENCO AGGIORNATO'!W:W), 0)")
If IsError(r) Then Exit Sub ' All is fine
Cancel = True
Application.Goto Sheets("ELENCO AGGIORNATO").Cells(r, "V").Resize(, 2)
msgBox "Please fill missing data before saving."
End Sub
Also note that I recommend Workbook_BeforeSave instead of Workbook_BeforeClose, because there's no harm if the user decides to drop his (incomplete) work and close the workbook without saving.
You may try something like this...
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim str As String
Dim Rng As Range, Cell As Range
Dim FoundBlank As Boolean
Set Rng = Sheet1.Range("A1:A1000")
str = "Please fill the cells listed below before colsing..." & vbNewLine & vbNewLine
For Each Cell In Rng
If Cell <> "" And Cell.Offset(0, 1) = "" Then
FoundBlank = True
str = str & Cell.Address(0, 1) & vbNewLine
End If
Next Cell
If FoundBlank Then
Cancel = True
MsgBox str, vbExclamation, "List of Blank Cells Found!"
End If
End Sub

Incorporating refedit into Vlookup userform

I have a vlookup userform which autofills the details in the form based on the seat n°.
Now I want to incoroporate a ref edit to paste these data from the text box to the cells the user chooses with the refedit. Hence i would need some help in going about these. This is the code i have used. I potentially want to insert 3 refedit boxes for user to select the cell they want to paste each of the data (Name,Dept and Ext No.) from the textbox.
See my code below:
Option Explicit
Private Sub Frame1_Click()
End Sub
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim answer As Integer
answer = TextBox1.Value
TextBox2.Value = WorksheetFunction.VLookup(answer, Sheets("L12 - Data Sheet").Range("B:E"), 2, False)
TextBox3.Value = WorksheetFunction.VLookup(answer, Sheets("L12 - Data Sheet").Range("B:E"), 3, False)
TextBox4.Value = WorksheetFunction.VLookup(answer, Sheets("L12 - Data Sheet").Range("B:E"), 4, False)
End Sub
Private Sub TextBox2_Change()
End Sub
Private Sub TextBox3_Change()
End Sub
Private Sub TextBox4_Change()
End Sub
Private Sub CancelButton_Click()
Unload Me
End
End Sub
I have tried figuring out a code to solve this issue but I am getting an object required error. My rngcopy would be textbox2.value (Name) and the rngpaste location would be the ref edit 1.
This is the code
Private Sub PasteButton_Click()
Dim rngCopy As Range, rngPaste As Range
Dim wsPaste As Range
Dim answer As Integer
answer = TextBox1.Value
If RefEdit1.Value <> "" Then
TextBox2.Value = WorksheetFunction.VLookup(answer, Sheets("L12 - Data Sheet").Range("B:E"), 2, False)
Set rngCopy = TextBox2.Value
Set wsPaste = ThisWorkbook.Sheets(Replace(Split(TextBox2.Value, "!")(0), "'", ""))
Set rngPaste = wsPaste.Range(Split(TextBox2.Value, "!")(1))
rngCopy.Copy rngPaste
Else
MsgBox "Please select an Output range"
End If
End Sub
You should get the row index with Match and expose it to the form so it can be used by the copy function.
And to set the target pointed by a Ref control, just evalute the .Value property with Range():
Range(RefEdit.Value).cells(1, 1) = Worksheet.Cells(row, column)
The form:
The code:
' constants to define the data
Const SHEET_DATA = "L12 - Data Sheet"
Const COLUMN_SEAT = "B"
Const COLUMNN_NAME = "C"
Const COLUMN_DEPT = "D"
Const COLUMN_EXTNO = "E"
Private Sheet As Worksheet
Private RowIndex As Long
Private Sub TxtSeatNo_Change()
Dim seatno
'clear the fields first
Me.TxtName.value = Empty
Me.TxtDept.value = Empty
Me.TxtExtNo.value = Empty
RowIndex = 0
If Len(TxtSeatNo.value) Then
Set Sheet = ThisWorkbook.Sheets(SHEET_DATA)
On Error Resume Next
' get the seat number to either string or double
seatno = TxtSeatNo.value
seatno = CDbl(seatno)
' get the row index containing the SeatNo
RowIndex = WorksheetFunction.match(seatno, _
Sheet.Columns(COLUMN_SEAT), _
0)
On Error GoTo 0
End If
If RowIndex Then
' copy the values from the sheet to the text boxes
Me.TxtName.value = Sheet.Cells(RowIndex, COLUMNN_NAME)
Me.TxtDept.value = Sheet.Cells(RowIndex, COLUMN_DEPT)
Me.TxtExtNo.value = Sheet.Cells(RowIndex, COLUMN_EXTNO)
End If
End Sub
Private Sub BtCopy_Click()
If RowIndex < 1 Then Exit Sub
' copy the current values to the cells pointed by the ref controls
If Len(Me.RefName.value) Then _
Range(Me.RefName.value) = Sheet.Cells(RowIndex, COLUMNN_NAME)
If Len(Me.RefDept.value) Then _
Range(Me.RefDept.value) = Sheet.Cells(RowIndex, COLUMN_DEPT)
If Len(Me.RefExtNo.value) Then _
Range(Me.RefExtNo.value) = Sheet.Cells(RowIndex, COLUMN_EXTNO)
End Sub
Private Sub BtlClose_Click()
' close the form
Unload Me
End Sub
You are declaring your rngCopy as a Range Object and then later on you are binding it to a .value method of the range object.
Set rngCopy = TextBox2.Value
This is likely where you are encountering errors. Try declaring a string and assigning it to your copy value.
Dim string1 As String
string1 = TextBox2.Value
Step through your code editor with the LOCALS window open, and watch what happens to your rngCopy object when you assign a string to it.

Update sheet with data from userform

I have a table and I have the form I built.
the user pick a name and surname from the table by the combobox in form
the user need to choose from combobox "yes/no" about this name
I need a vba code (excel) so that it can find the name (after the user picked it) in the table
and then update the yes/no column by the correct row.
I created a module and added this:
Option Explicit
Public Sub update_sheet(workername As String)
'--> If the user was selected on the form update column F to Yes
Dim ws As Worksheet
Dim rowno As Long
Set ws = Sheets("workers")
With ws
rowno = .Range("C:C").Find(workername).Row
.Cells(rowno, 6).Value = "Yes"
End With
End Sub
On the form code:
Private Sub cb_select_change()
Call update_sheet(cb_select.Value)
End Sub
where your combo box is called cb_select
You'll need to do some work on this to make it into what you need, but it should get you started:
Private Sub CommandButton1_Click()
Dim rng_ToSearch As Excel.Range
Dim rng_Found As Excel.Range
On Error GoTo ErrorHandler
'Change this to the range that contains your names. I'm assuming that
'it's a single column and has the Yes/No column alongside.
Set rng_ToSearch = Sheet1.Range("MyTable_Names")
'Change the What argument to reflect the name of your form's
'control.
Set rng_Found = rng_ToSearch.Find(What:=Me.ComboBox1.Value, _
After:=rng_ToSearch.Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'This shouldn't happen if you've populated the name selection
'box correctly and have not allowed users to add to it.
'This is left as an exercise for the reader.
If rng_Found Is Nothing Then
Err.Raise vbObjectError + 2000, , "Either the selected name was " _
& "not found in the list, or no selection was made."
End If
'Again, change the control name to your own.
rng_Found.Offset(0, 1) = Me.ComboBox2.Value
ExitPoint:
On Error Resume Next
Set rng_ToSearch = Nothing
Set rng_Found = Nothing
On Error GoTo 0
Exit Sub
ErrorHandler:
MsgBox "Error in updating users: " & Err.Number & vbCrLf & Err.Description
Resume ExitPoint
End Sub
THIS IS MY CODE SO FAR
Private Sub RefEdit1_BeforeDragOver(Cancel As Boolean, ByVal Data As msforms.DataObject, ByVal x As stdole.OLE_XPOS_CONTAINER, ByVal y As stdole.OLE_YPOS_CONTAINER, ByVal DragState As msforms.fmDragState, Effect As msforms.fmDropEffect, ByVal Shift As Integer)
End Sub
Private Sub ClsFrmE_Click()
Unload Me
End Sub
Private Sub cmdAdd_Click()
Dim lRow As Long
Dim ws As Worksheet
Set ws = Worksheets("workers")
'???÷? ?? ?????? ?????
If Trim(Me.cmbWN.Value) = "" Then
Me.cmbWN.SetFocus
MsgBox "???? ?? ????"
Exit Sub
End If
If Trim(Me.tbDate.Value) = "" Then
Me.tbDate.SetFocus
MsgBox "???? ????? ?????"
Exit Sub
End If
'copy the data to the database
'use protect and unprotect lines,
' with your password
' if worksheet is protected
With ws
' .Unprotect Password:="password"
If Trim(Me.dNdcmb.Value) = "????" Then
.Cells(lRow, 6).Value = 1
Else
.Cells(lRow, 6).Value = 0
End If
.Cells(lRow, 7).Value = Me.tbDate.Value
'.Cells(lRow, 2).Value = Me.cboPart.List(lPart, 1)
' .Protect Password:="password"
End With
'clear the data
Me.cmbWN.Value = ""
Me.tbDate.Value = ""
Me.cmbWN.SetFocus
ActiveWorkbook.Save
End Sub
Private Sub UserForm_Initialize()
Dim cFullName As Range
Dim cDnd As Range
Dim ws As Worksheet
Set ws = Worksheets("workers")
For Each cFullName In ws.Range("??????")
With Me.cmbWN
.AddItem cFullName.Value
.List(.ListCount - 1, 1) = cFullName.Offset(0, 1).Value
End With
Next cFullName
For Each cDnd In ws.Range("??????????")
With Me.dNdcmb
.AddItem cDnd.Value
End With
Next cDnd
Me.dNdcmb.Text = Me.dNdcmb.List(Me.dNdcmb.ListCount - 2)
Me.cmbWN.SetFocus
End Sub

How do I get the old value of a changed cell in Excel VBA?

I'm detecting changes in the values of certain cells in an Excel spreadsheet like this...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim old_value As String
Dim new_value As String
For Each cell In Target
If Not (Intersect(cell, Range("cell_of_interest")) Is Nothing) Then
new_value = cell.Value
old_value = ' what here?
Call DoFoo (old_value, new_value)
End If
Next cell
End Sub
Assuming this isn't too bad a way of coding this, how do I get the value of the cell before the change?
try this
declare a variable say
Dim oval
and in the SelectionChange Event
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
oval = Target.Value
End Sub
and in your Worksheet_Change event set
old_value = oval
You can use an event on the cell change to fire a macro that does the following:
vNew = Range("cellChanged").value
Application.EnableEvents = False
Application.Undo
vOld = Range("cellChanged").value
Range("cellChanged").value = vNew
Application.EnableEvents = True
I had to do it too. I found the solution from "Chris R" really good, but thought it could be more compatible in not adding any references. Chris, you talked about using Collection. So here is another solution using Collection. And it's not that slow, in my case. Also, with this solution, in adding the event "_SelectionChange", it's always working (no need of workbook_open).
Dim OldValues As New Collection
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Copy old values
Set OldValues = Nothing
Dim c As Range
For Each c In Target
OldValues.Add c.Value, c.Address
Next c
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Local Error Resume Next ' To avoid error if the old value of the cell address you're looking for has not been copied
Dim c As Range
For Each c In Target
Debug.Print "New value of " & c.Address & " is " & c.Value & "; old value was " & OldValues(c.Address)
Next c
'Copy old values (in case you made any changes in previous lines of code)
Set OldValues = Nothing
For Each c In Target
OldValues.Add c.Value, c.Address
Next c
End Sub
I have an alternative solution for you. You could create a hidden worksheet to maintain the old values for your range of interest.
Private Sub Workbook_Open()
Dim hiddenSheet As Worksheet
Set hiddenSheet = Me.Worksheets.Add
hiddenSheet.Visible = xlSheetVeryHidden
hiddenSheet.Name = "HiddenSheet"
'Change Sheet1 to whatever sheet you're working with
Sheet1.UsedRange.Copy ThisWorkbook.Worksheets("HiddenSheet").Range(Sheet1.UsedRange.Address)
End Sub
Delete it when the workbook is closed...
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
Me.Worksheets("HiddenSheet").Delete
Application.DisplayAlerts = True
End Sub
And modify your Worksheet_Change event like so...
For Each cell In Target
If Not (Intersect(cell, Range("cell_of_interest")) Is Nothing) Then
new_value = cell.Value
' here's your "old" value...
old_value = ThisWorkbook.Worksheets("HiddenSheet").Range(cell.Address).Value
Call DoFoo(old_value, new_value)
End If
Next cell
' Update your "old" values...
ThisWorkbook.Worksheets("HiddenSheet").UsedRange.Clear
Me.UsedRange.Copy ThisWorkbook.Worksheets("HiddenSheet").Range(Me.UsedRange.Address)
Here's a way I've used in the past. Please note that you have to add a reference to the Microsoft Scripting Runtime so you can use the Dictionary object - if you don't want to add that reference you can do this with Collections but they're slower and there's no elegant way to check .Exists (you have to trap the error).
Dim OldVals As New Dictionary
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
For Each cell In Target
If OldVals.Exists(cell.Address) Then
Debug.Print "New value of " & cell.Address & " is " & cell.Value & "; old value was " & OldVals(cell.Address)
Else
Debug.Print "No old value for " + cell.Address
End If
OldVals(cell.Address) = cell.Value
Next
End Sub
Like any similar method, this has its problems - first off, it won't know the "old" value until the value has actually been changed. To fix this you'd need to trap the Open event on the workbook and go through Sheet.UsedRange populating OldVals. Also, it will lose all its data if you reset the VBA project by stopping the debugger or some such.
an idea ...
write these in the ThisWorkbook module
close and open the workbook
Public LastCell As Range
Private Sub Workbook_Open()
Set LastCell = ActiveCell
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Set oa = LastCell.Comment
If Not oa Is Nothing Then
LastCell.Comment.Delete
End If
Target.AddComment Target.Address
Target.Comment.Visible = True
Set LastCell = ActiveCell
End Sub
Place the following in the CODE MODULE of a WORKSHEET to track the last value for every cell in the used range:
Option Explicit
Private r As Range
Private Const d = "||"
Public Function ValueLast(r As Range)
On Error Resume Next
ValueLast = Split(r.ID, d)(1)
End Function
Private Sub Worksheet_Activate()
For Each r In Me.UsedRange: Record r: Next
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
For Each r In Target: Record r: Next
End Sub
Private Sub Record(r)
r.ID = r.Value & d & Split(r.ID, d)(0)
End Sub
And that's it.
This solution uses the obscure and almost never used
Range.ID property, which allows the old values to persist when the workbook is saved and closed.
At any time you can get at the old value of
a cell and it will indeed be different than a new current value:
With Sheet1
MsgBox .[a1].Value
MsgBox .ValueLast(.[a1])
End With
I've expanded a bit on Matt Roy's solution which is awesome by the way. What I did is handle situations when the user selects the whole row/column, so the macro only record the intersection between selection and ".UsedRange", and also handled situations where selection is not a range (for buttons, shapes, pivot tables)
Sub trackChanges_loadOldValues_toCollection(ByVal Target As Range)
'LOADS SELECTION AND VALUES INTO THE COLLECTION collOldValues
If isErrorHandlingOff = False Then: On Error GoTo endWithError
Dim RngI As Range, newTarget As Range, arrValues, arrFormulas, arrAddress
'DON'T RECORD WHEN SELECTING BUTTONS OR SHAPES, ONLY FOR RANGES
If TypeName(Target) <> "Range" Then: Exit Sub
'RESET OLD VALUES COLLECITON
Set collOldValues = Nothing
'ONLY RECORD CELLS IN USED RANGE, TO AVOID ISSUES WHEN SELECTING WHOLE ROW
Set newTarget = Intersect(Target, Target.Parent.UsedRange)
'newTarget.Select
If Not newTarget Is Nothing Then
For Each RngI In newTarget
'ADD TO COLLECTION
'ITEM, KEY
collOldValues.add Array(RngI.value, RngI.formula), RngI.Address
Next RngI
End If
done:
Exit Sub
endWithError:
DisplayError Err, "trackChanges_loadOldValues_toCollection", Erl
End Sub
try this, it will not work for the first selection, then it will work nice :)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo 10
If Target.Count > 1 Then GoTo 10
Target.Value = lastcel(Target.Value)
10
End Sub
Function lastcel(lC_vAl As String) As String
Static vlu
lastcel = vlu
vlu = lC_vAl
End Function
I had a need to capture and compare old values to the new values entered into a complex scheduling spreadsheet. I needed a general solution which worked even when the user changed many rows at the same time. The solution implemented a CLASS and a COLLECTION of that class.
The class: oldValue
Private pVal As Variant
Private pAdr As String
Public Property Get Adr() As String
Adr = pAdr
End Property
Public Property Let Adr(Value As String)
pAdr = Value
End Property
Public Property Get Val() As Variant
Val = pVal
End Property
Public Property Let Val(Value As Variant)
pVal = Value
End Property
There are three sheets in which i track cells. Each sheet gets its own collection as a global variable in the module named ProjectPlan as follows:
Public prepColl As Collection
Public preColl As Collection
Public postColl As Collection
Public migrColl As Collection
The InitDictionaries SUB is called out of worksheet.open to establish the collections.
Sub InitDictionaries()
Set prepColl = New Collection
Set preColl = New Collection
Set postColl = New Collection
Set migrColl = New Collection
End Sub
There are three modules used to manage each collection of oldValue objects they are Add, Exists, and Value.
Public Sub Add(ByRef rColl As Collection, ByVal sAdr As String, ByVal sVal As Variant)
Dim oval As oldValue
Set oval = New oldValue
oval.Adr = sAdr
oval.Val = sVal
rColl.Add oval, sAdr
End Sub
Public Function Exists(ByRef rColl As Collection, ByVal sAdr As String) As Boolean
Dim oReq As oldValue
On Error Resume Next
Set oReq = rColl(sAdr)
On Error GoTo 0
If oReq Is Nothing Then
Exists = False
Else
Exists = True
End If
End Function
Public Function Value(ByRef rColl As Collection, ByVal sAdr) As Variant
Dim oReq As oldValue
If Exists(rColl, sAdr) Then
Set oReq = rColl(sAdr)
Value = oReq.Val
Else
Value = ""
End If
End Function
The heavy lifting is done in the Worksheet_SelectionChange callback. One of the four is shown below. The only difference is the collection used in the ADD and EXIST calls.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim mode As Range
Set mode = Worksheets("schedule").Range("PlanExecFlag")
If mode.Value = 2 Then
Dim c As Range
For Each c In Target
If Not ProjectPlan.Exists(prepColl, c.Address) Then
Call ProjectPlan.Add(prepColl, c.Address, c.Value)
End If
Next c
End If
End Sub
THe VALUE call is called out of code executed from the Worksheet_Change Callback for example. I need to assign the correct collection based on the sheet name:
Dim rColl As Collection
If sheetName = "Preparations" Then
Set rColl = prepColl
ElseIf sheetName = "Pre-Tasks" Then
Set rColl = preColl
ElseIf sheetName = "Migr-Tasks" Then
Set rColl = migrColl
ElseIf sheetName = "post-Tasks" Then
Set rColl = postColl
Else
End If
and then i am free to compute compare the some current value to the original value.
If Exists(rColl, Cell.Offset(0, 0).Address) Then
tsk_delay = Cell.Offset(0, 0).Value - Value(rColl, Cell.Offset(0, 0).Address)
Else
tsk_delay = 0
End If
Mark
Let's first see how to detect and save the value of a single cell of interest. Suppose Worksheets(1).Range("B1") is your cell of interest. In a normal module, use this:
Option Explicit
Public StorageArray(0 to 1) As Variant
' Declare a module-level variable, which will not lose its scope as
' long as the codes are running, thus performing as a storage place.
' This is a one-dimensional array.
' The first element stores the "old value", and
' the second element stores the "new value"
Sub SaveToStorageArray()
' ACTION
StorageArray(0) = StorageArray(1)
' Transfer the previous new value to the "old value"
StorageArray(1) = Worksheets(1).Range("B1").value
' Store the latest new value in Range("B1") to the "new value"
' OUTPUT DEMONSTRATION (Optional)
' Results are presented in the Immediate Window.
Debug.Print "Old value:" & vbTab & StorageArray(0)
Debug.Print "New value:" & vbTab & StorageArray(1) & vbCrLf
End Sub
Then in the module of Worksheets(1):
Option Explicit
Private HasBeenActivatedBefore as Boolean
' Boolean variables have the default value of False.
' This is a module-level variable, which will not lose its scope as
' long as the codes are running.
Private Sub Worksheet_Activate()
If HasBeenActivatedBefore = False then
' If the Worksheet has not been activated before, initialize the
' StorageArray as follows.
StorageArray(1) = Me.Range("B1")
' When the Worksheets(1) is activated, store the current value
' of Range("B1") to the "new value", before the
' Worksheet_Change event occurs.
HasBeenActivatedBefore = True
' Set this parameter to True, so that the contents
' of this if block won't be evaluated again. Therefore,
' the initialization process above will only be executed
' once.
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("B1")) Is Nothing then
Call SaveToStorageArray
' Only perform the transfer of old and new values when
' the cell of interest is being changed.
End If
End Sub
This will capture the change of the Worksheets(1).Range("B1"), whether the change is due to the user actively selecting that cell on the Worksheet and changing the value, or due to other VBA codes that change the value of Worksheets(1).Range("B1").
Since we have declared the variable StorageArray as public, you can reference its latest value in other modules in the same VBA project.
To expand our scope to the detection and saving the values of multiple cells of interest, you need to:
Declare the StorageArray as a two-dimensional array, with the number of rows equal to the number of cells you are monitoring.
Modify the Sub SaveToStorageArray procedure to a more general Sub SaveToStorageArray(TargetSingleCell as Range) and change the
relevant codes.
Modify the Private Sub Worksheet_Change procedure to accommodate the monitoring of those multiple cells.
Appendix:
For more information on the lifetime of variables, please refer to: https://msdn.microsoft.com/en-us/library/office/gg278427.aspx
I needed this feature and I did not like all the solutions above after trying most as they are either
Slow
Have complex implications like using application.undo.
Do not capture if they were not selected
Do not captures values if they were not changed before
Too complex
Well I thought very hard about it and I completed a solution for a full UNDO,REDO history.
To capture the old value it is actually very easy and very fast.
My solution is to capture all values once the user open the sheet is open into a variable and it gets updated after each change. this variable will be used to check the old value of the cell. In the solutions above all of them used for loop. Actually there is way easier method.
To capture all the values I used this simple command
SheetStore = sh.UsedRange.Formula
Yeah, just that, Actually excel will return an array if the range is a multiple cells so we do not need to use FOR EACH command and it is very fast
The following sub is the full code which should be called in Workbook_SheetActivate. Another sub should be created to capture the changes. Like, I have a sub called "catchChanges" that runs on Workbook_SheetChange. It will capture the changes then save them on another a change history sheet. then runs UpdateCache to update the cache with the new values
' should be added at the top of the module
Private SheetStore() As Variant
Private SheetStoreName As String ' I use this variable to make sure that the changes I captures are in the same active sheet to prevent overwrite
Sub UpdateCache(sh As Object)
If sh.Name = ActiveSheet.Name Then ' update values only if the changed values are in the activesheet
SheetStoreName = sh.Name
ReDim SheetStore(1 To sh.UsedRange.Rows.count, 1 To sh.UsedRange.Columns.count) ' update the dimension of the array to match used range
SheetStore = sh.UsedRange.Formula
End If
End Sub
now to get the old value it is very easy as the array have the same address of cells
examples if we want cell D12 we can use the following
SheetStore(row_number,column_number)
'example
return = SheetStore(12,4)
' or the following showing how I used it.
set cell = activecell ' the cell that we want to find the old value for
newValue = cell.value ' you can ignore this line, it is just a demonstration
oldValue = SheetStore(cell.Row, cell.Column)
these are snippet explaining the method, I hope everyone like it
In response to Matt Roy answer, I found this option a great response, although I couldn't post as such with my current rating. :(
However, while taking the opportunity to post my thoughts on his response, I thought I would take the opportunity to include a small modification. Just compare code to see.
So thanks to Matt Roy for bringing this code to our attention, and Chris.R for posting original code.
Dim OldValues As New Collection
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'>> Prevent user from multiple selection before any changes:
If Selection.Cells.Count > 1 Then
MsgBox "Sorry, multiple selections are not allowed.", vbCritical
ActiveCell.Select
Exit Sub
End If
'Copy old values
Set OldValues = Nothing
Dim c As Range
For Each c In Target
OldValues.Add c.Value, c.Address
Next c
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
On Local Error Resume Next ' To avoid error if the old value of the cell address you're looking for has not been copied
Dim c As Range
For Each c In Target
If OldValues(c.Address) <> "" And c.Value <> "" Then 'both Oldvalue and NewValue are Not Empty
Debug.Print "New value of " & c.Address & " is " & c.Value & "; old value was " & OldValues(c.Address)
ElseIf OldValues(c.Address) = "" And c.Value = "" Then 'both Oldvalue and NewValue are Empty
Debug.Print "New value of " & c.Address & " is Empty " & c.Value & "; old value is Empty" & OldValues(c.Address)
ElseIf OldValues(c.Address) <> "" And c.Value = "" Then 'Oldvalue is Empty and NewValue is Not Empty
Debug.Print "New value of " & c.Address & " is Empty" & c.Value & "; old value was " & OldValues(c.Address)
ElseIf OldValues(c.Address) = "" And c.Value <> "" Then 'Oldvalue is Not Empty and NewValue is Empty
Debug.Print "New value of " & c.Address & " is " & c.Value & "; old value is Empty" & OldValues(c.Address)
End If
Next c
'Copy old values (in case you made any changes in previous lines of code)
Set OldValues = Nothing
For Each c In Target
OldValues.Add c.Value, c.Address
Next c
I have the same problem like you and luckily I have read the solution from this link:
http://access-excel.tips/value-before-worksheet-change/
Dim oldValue As Variant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
oldValue = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'do something with oldValue...
End Sub
Note: you must place oldValue variable as a global variable so all subclasses can use it.
Private Sub Worksheet_Change(ByVal Target As Range)
vNEW = Target.Value
aNEW = Target.Address
Application.EnableEvents = False
Application.Undo
vOLD = Target.Value
Target.Value = vNEW
Application.EnableEvents = True
End Sub
Using Static will solve your problem (with some other stuff to initialize old_value properly:
Private Sub Worksheet_Change(ByVal Target As Range)
Static old_value As String
Dim inited as Boolean 'Used to detect first call and fill old_value
Dim new_value As String
If Not Intersect(cell, Range("cell_of_interest")) Is Nothing Then
new_value = Range("cell_of_interest").Value
If Not inited Then
inited = True
Else
Call DoFoo (old_value, new_value)
End If
old_value = new_value
Next cell
End Sub
In workbook code, force call of Worksheet_change to fill old_value:
Private Sub Private Sub Workbook_Open()
SheetX.Worksheet_Change SheetX.Range("cell_of_interest")
End Sub
Note, however, that ANY solution based in VBA variables (including dictionary and another more sophisticate methods) will fail if you stop (Reset) running code (eg. while creating new macros, debugging some code, ...). To avoid such, consider using alternative storage methods (hidden worksheet, for example).
I have read this old post, and I would like to provide another solution.
The problem with running Application.Undo is that Woksheet_Change runs again. We have the same problem when we restore.
To avoid that, I use a piece of code to avoid the second steps through Worksheet_Change.
Before we begin, we must create a Boolean static variable BlnAlreadyBeenHere, to tell Excel not to run Worksheet_Change again
Here you can see it:
Private Sub Worksheet_Change(ByVal Target As Range)
Static blnAlreadyBeenHere As Boolean
'This piece avoid to execute Worksheet_Change again
If blnAlreadyBeenHere Then
blnAlreadyBeenHere = False
Exit Sub
End If
'Now, we will store the old and new value
Dim vOldValue As Variant
Dim vNewValue As Variant
'To store new value
vNewValue = Target.Value
'Undo to retrieve old value
'To avoid new Worksheet_Change execution
blnAlreadyBeenHere = True
Application.Undo
'To store old value
vOldValue = Target.Value
'To rewrite new value
'To avoid new Worksheet_Change execution agein
blnAlreadyBeenHere = True
Target.Value = vNewValue
'Done! I've two vaules stored
Debug.Print vOldValue, vNewValue
End Sub
The advantage of this method is that it is not necessary to run Worksheet_SelectionChange.
If we want the routine to work from another module, we just have to take the declaration of the variable blnAlreadyBeenHere out of the routine, and declare it with Dim.
Same operation with vOldValue and vNewValue, in the header of a module
Dim blnAlreadyBeenHere As Boolean
Dim vOldValue As Variant
Dim vNewValue As Variant
Just a thought, but Have you tried using application.undo
This will set the values back again. You can then simply read the original value. It should not be too difficult to store the new values first, so you change them back again if you like.