Hi everyone I am trying to figure out how to write a code where users can only input the exact same data into cells from a list I created. I want the code to validate the user entry and see if the entry is on the list and if is not to erase the data the user enter and give him a message. I am almost there but I don't seem to make my Vlook work. Any help would be very much appreciate it. below is the code I wrote
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim rng As Range
Dim aCell As Range
Dim LU As Range
Dim Celda As Range
'
On Error GoTo Whoa
Application.EnableEvents = False
'~~> This is the range of cells where I want the user to input the data
Set rng = Range("A1:A15")
'THis is the range where I want the macro to look if the data the user entered is in the list
Set LU = Application.WorksheetFunction.VLookup(aCell.Value, Range("F1:F5"), 1, False)
On Error GoTo MyErrorHandler:
If Not Application.Intersect(Target, rng) Is Nothing Then
'~~> Loop through all cells in the range
For Each aCell In rng
If aCell.Value <> "" Then
If aCell.Value <> LU Then
aCell.ClearContents
MyErrorHandler:
If Err.Number = 1004 Then
aCell.ClearContents
MsgBox "Item Number es Incorrecto - Error en la celda " & aCell.Address
End If
End If
End If
Next
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Use Data - Data Validation, set to Allow by List. For source place =$F$1:$F$5. Customize options to your needs. No VBA needed.
Related
I am trying to run this worksheet change event for two different columns(A) and (I)...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
r.Offset(0, 1).Value = Date
Next r
Application.EnableEvents = True
End Sub
This event is something i found on this forum. Its purpose is to make it so whenever data is ever entered into column "a" it auto inputs the date into the cell directly right of it. I want this to happen twice on the worksheet. I can't figure out how to change/add to it. I am trying to get it to run the logic for column A and I on my spreadsheet.
Just expand the range you set to the A variable.
Set A = Range("A:A, I:I")
Rewritten as,
Private Sub Worksheet_Change(ByVal Target As Range)
if not intersect(range("A:A, I:I"), target) is nothing then
'add error control
on error goto safe_exit
'don't do anything until you know something has to be done
dim r as range
Application.EnableEvents = False
For Each r In intersect(range("A:A, I:I"), target)
r.Offset(0, 1).Value = Date 'do you want Date or Now?
Next r
end if
safe_exit:
Application.EnableEvents = True
End Sub
edited after OP's comment
expanding on #Jeeped solution, you can avoid looping:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Intersect(Range("A:A, I:I"), Target) ' define range of interest
If Not rng Is Nothing Then ' check it's not "nothing"
If WorksheetFunction.CountA(rng) = rng.Count Then 'check for all of its cells being not empty
On Error GoTo safe_exit 'add error control
Application.EnableEvents = False 'don't do anything until you know something has to be done
rng.Offset(, 1).Value = Date 'write Date next to all relevant changed cells
End If
End If
safe_exit:
Application.EnableEvents = True
End Sub
I have a macro up and running that sorts a pivot table, copies a range of cells out of the table and then pastes those into a second sheet. To be honest, with where I'm at with VBA right now I'm pretty happy with this feat alone. Yet I have more things I want it to do.
What I want to happen is this: The macro I have pastes data into the first empty cells in column A. When this happens I want the macro to enter today's date (preferably in a manner that makes it permanent and won't change to tomorrow's date tomorrow) in the same row in column C and the text "IV020" into column D.
In Sheet9 I have the following code (mainly taken from posts here):
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aCell As Range
On Error GoTo Whoa
Application.EnableEvents = False
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Not Target.Columns.Count > 1 Then
For Each aCell In Target
If aCell.Value <> "" And aCell.Offset(0, 2).NumberFormat = "" Then
aCell.Offset(0, 2).Value = "=TODAY()"
aCell.Offset(0, 3).Value = "IV020"
End If
Next
Else
MsgBox "Please paste in 1 Column"
End If
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Yet when things are pasted or entered manually into Column A, nothing happens.
You cannot have a Range.NumberFormat property that is a zero-length string. Even if you tried to put one in manually, it would reset itself to General.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns(1)) Is Nothing Then
'don't do things until you have to
On Error GoTo Whoa
Application.EnableEvents = False
Dim aCell As Range
'this processes all of the cells that were changes in column A
For Each aCell In Intersect(Target, Columns(1))
'If aCell.Value <> "" And aCell.Offset(0, 2).NumberFormat = "" Then
If aCell.Value <> "" Then
aCell.Offset(0, 2).Value = Date 'possibly Now but likely not "=TODAY()"
aCell.Offset(0, 3).Value = "IV020"
End If
Next
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
I've made some minor changes; you will have to decide what you want to do about the .NumberFormat issue.
I'd like the user to input a range of cells such as A1:Z26. I've tried adding quotations, I've tried have 2 inputboxes, one for beginning and end of the range. But it errors out everytime with: 'method range of object_global failed'
I know it's a simple syntax issue (I think) so can anyone point me in the right direction in terms of how to have the user input a range that works in the set rng = range(msg)
Sub iterationLoop()
Dim rng As Range, iteration As Range
msg = "What is the range you'd like to look at: (e.g. A1:B2)"
InputBox (msg)
Set rng = Range(msg)
For Each iteration In rng
iteration.Select
If iteration = vbNullString Then
iteration = "add value"
MsgBox ("Cell: " & Selection.Address & " has no value")
End If
Next
End Sub
Application.InputBox allows you to specify the input type. Type 8 corresponds to a range. This will allow the user to either select the range with a mouse or type it in manually:
Sub test()
Dim rng As Range
Set rng = Application.InputBox("Select by mouse or enter (e.g. A1:B2) the range you'd like to look at:", Type:=8)
MsgBox rng.Address
End Sub
If you intend your code to be used by others, you should probably wrap the Application.InputBox call in some error-handling code since the above code raises a run-time error if the user presses Cancel. Something like:
On Error Resume Next
Set rng = Application.InputBox("Select by mouse or enter (e.g. A1:B2) the range you'd like to look at:", Type:=8)
If Err.Number > 0 Then
MsgBox "No Range Selected"
Exit Sub
End If
On Error GoTo 0
(though you might want to do something more useful than just quitting the sub)
aAdd
Dim rngstr as string
Then with the inputbox use this:
rngstr = inputbox(msg)
set rng = Range(rngstr)
i have designed a few codes to help remove reference errors however it does not automatically delete until i assign the macro to a button. i do not want it that way as it would seem unpleasant when i want to present the programme to my team members, and having to remove the errors on the spot with a button. I thought of combining my delete cells code and remove reference cell codes together so that they would run simultaneously but to no avail. Is it possible to combine these two codes to achieve my objective or are there any solutions or coding to remove/hide reference errors automatically? Here are the two codes. All of your help would be very much appreciated!
Sub deletetry2()
Dim R As Range
Set rng = Nothing
On Error Resume Next
Set R = Application.InputBox("Select cells To be deleted", Type:=8)
If TypeName(R) <> "Range" Then
Exit Sub
Else
R.Delete
End If
End Sub
Sub Check_ReferenceDeletecolumn()
Dim rng As Range
Dim rngError As Range
Set rng = Sheets("Sheet3").Range("A1:G100")
On Error Resume Next
Set rngError = rng.Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If Not rngError Is Nothing Then
rngError.EntireColumn.Delete
'delete means cells will move up after deleting that entire row
End If
End Sub
If the objective is to remove all rows containing errors, from a user defined range, this should work:
Option Explicit
Public Sub cleanUserDefinedRange()
Dim response As Range
On Error Resume Next
Set response = Application.InputBox("Select range to clean up errors", Type:=8)
If Not response Is Nothing Then cleanUpErrors response
On Error GoTo 0
End Sub
'------------------------------------------------------------------------------------------
Private Sub cleanUpErrors(ByRef rng As Range)
Application.ScreenUpdating = False
rng.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
Application.ScreenUpdating = True
End Sub
I am using the SHEETOFFSET VBA code
Function SHEETOFFSET(offset, Ref)
' Returns cell contents at Ref, in sheet offset
Application.Volatile
With Application.Caller.Parent
SHEETOFFSET = .Parent.Sheets(.Index + offset) _
.Range(Ref.Address).Value
End With
End Function
And then the following code within within my new sheet
=sheetoffset(-1, B2)
to copy the value of cell B2 in the previous sheet to my new sheet.
However, I also need to copy the color of that particular cell. Is there any code that I can enter in the original VBA code above to do this? Or is there another way of achieving this?
Many thanks for your help
Tim
Logic:
Define a Public variable to hold the color of the cell
In Worksheet_Change check if the above variable has any value. If yes then change the color of the target cell.
Once the above is done, reset the variable to 0
Code in Module:
Public cellColor As Double
Function SHEETOFFSET(offset, Ref)
With Application.Caller.Parent
SHEETOFFSET = .Parent.Sheets(.Index + offset) _
.Range(Ref.Address).Value
'~~> Store the color in a variable
cellColor = .Parent.Sheets(.Index + offset) _
.Range(Ref.Address).Interior.ColorIndex
End With
End Function
Code in Sheet Code Area:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aCell As Range
On Error GoTo Whoa
Application.EnableEvents = False
For Each aCell In Target.Cells
If cellColor <> 0 Then aCell.Interior.ColorIndex = cellColor
Next
Letscontinue:
cellColor = 0
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
ScreenShot:
My Personal Thoughts:
I am not in favor of the SHEETOFFSET function in the first place because the formula is actually referring a cell in the current sheet. Any changes, for example, deletion of that cell will error out your formula
It is better to link the cells directly
FOLLOWUP (From Comments)
You can run this code in the end to refresh all formulas.
Sub Sample()
Dim ws As Worksheet
Dim rng As Range, aCell As Range
For Each ws In ThisWorkbook.Sheets
Set rng = Nothing
On Error Resume Next
Set rng = ws.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rng Is Nothing Then
For Each aCell In rng
aCell.Formula = aCell.Formula
Next
End If
Next
End Sub