I need to restrict users entering duplicate values in the columns 2 and 5 compared to the columns 2 and 5 in a previous row
My code restricts entering duplicates if either Column 2 OR Column 5 has duplicates compared to the values for these columns in a previous row.
My goal is to have a warning / action when both columns have duplicate values.
Screenshot example:
VBA code in "Sheet1":
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If (.Column <> 2 And .Column <> 5) Or .Cells.Count > 1 Then Exit Sub
If WorksheetFunction.CountIfs(Columns(.Column), .Value) > 1 Then
Application.DisplayAlerts = False
.ClearContents
Application.DisplayAlerts = True
MsgBox "Duplicate value!"
End If
End With
End Sub
Use Find, FindNext on column 2 and then check the value in column 5. Note - this will find duplicate in any row not just the previous.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const PK1 = 2 ' Primary Keys
Const PK2 = 5
Dim V1, V2, rng As Range, first As String
If (Target.Column = PK1) Or (Target.Column = PK2) Then
V1 = Me.Cells(Target.Row, PK1) ' B
V2 = Me.Cells(Target.Row, PK2) ' E
If V1 = "" Or V2 = "" Then Exit Sub
Else
Exit Sub
End If
With Me.Columns(PK1)
Set rng = .Find(V1, lookat:=xlWhole, LookIn:=xlValues)
If Not rng Is Nothing Then
first = rng.Address
Do
If (rng.Row <> Target.Row) And (Cells(rng.Row, PK2) = V2) Then
MsgBox "Duplicate Value " & V1 & "," & V2, vbExclamation, "Row " & rng.Row
Target.Select
Application.EnableEvents = False
Target.Clear
Application.EnableEvents = True
Exit Do
End If
Set rng = .FindNext(rng)
Loop While rng.Address <> first
End If
End With
End Sub
Related
I am trying to link 2 cells that have data validation lists in them so that when 1 of the cells (ex. cell A2) is filled with the SKU in from a selection in the dropdown list, cell B2 will be filled with the SKU description and vice versa.
See the pictures below with that I have so far. I have named the columns:
Column A = a_val
Column B = b_val
SKU column with values = vrac
SKU description column with values = vrac_description
Table with SKUs and SKU descriptions = description
See the attached pictures for what I currently have.
1 sheet is the empty fields, I have data validation lists on columns A and B since I want to be able to have the option to select either from column A or column B but would like either one to auto-populate when I've selected an item from the list in the opposite cell
Thank you!
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("a_val")) Is Nothing Then
With Application.WorksheetFunction
UI False
Range("b_val").Value = .Index(Range("vrac_description").Value, .Match(Range("a_val").Value, Range("description").Value, 0))
UI True
End With
ElseIf Not Intersect(Target, [b_val]) Is Nothing Then
With Application.WorksheetFunction
UI False
[a_val].Value = .Index([vrac], .Match([b_val], [vrac_description], 0))
UI True
End With
End If
End Sub
Public Sub UI(t As Boolean)
Application.EnableEvents = t
Application.ScreenUpdating = t
End Sub
Current Code
Main Sheet
Data Validation Lookup
[EDIT} New code attempt:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, a_val) Is Nothing Then
With Application.WorksheetFunction
UI False
'b_val = .VLookup(Target, Description, 1, 0)
Range(Target.Column + 1).Value = .Index(vrac_description, .Match(Target.Value, vrac, 0))
UI True
End With
ElseIf Not Intersect(Target, b_val) Is Nothing Then
With Application.WorksheetFunction
UI False
'Range(Target.Column - 1).Value = .VLookup(Target.Value, Description, 1, 0)
Range(Target.Column - 1).Value = .Index(vrac, .Match(Target.Value, vrac_description, 0))
UI True
End With
End If
End Sub
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Msgbox "Target=" & Target.Address
On Error GoTo errorexit
Dim r, i As Long, cell As Range
i = Target.Column
If i > 2 Or Target.Value = "" Then Exit Sub
Set cell = Target.Offset(, 3 - i * 2)
With Sheets("Data_Validation").ListObjects("description").DataBodyRange
r = Application.Match(Target.Value, .Columns(i), 0)
If Not IsError(r) Then
Application.EnableEvents = False
cell = .Cells(r, 3 - i).Value
Else
MsgBox Target.Value & " not found in column " & i
End If
End With
errorexit:
Application.EnableEvents = True
End Sub
Your code corrected
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo exiterror
Dim a_val As Range, b_val As Range
Dim vrac As Range, vrac_description As Range
' define ranges
With ThisWorkbook
Set a_val = .Names("a_val").RefersToRange
Set b_val = .Names("b_val").RefersToRange
Set vrac = .Names("vrac").RefersToRange
Set vrac_description = .Names("vrac_description").RefersToRange
End With
If Not Intersect(Target, a_val) Is Nothing Then
With Application.WorksheetFunction
UI False
Target.Offset(, 1).Value = .Index(vrac_description, .Match(Target.Value, vrac, 0))
UI True
End With
ElseIf Not Intersect(Target, b_val) Is Nothing Then
With Application.WorksheetFunction
UI False
Target.Offset(, -1).Value = .Index(vrac, .Match(Target.Value, vrac_description, 0))
UI True
End With
End If
exiterror:
Application.EnableEvents = True
End Sub
I'm using Worksheet_Change to make a value (either 1 or 0) appear in the next cell (Bx) when a value is entered in a range of cells (A1:A10).
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
If Target.Value = 1 Then
Target.Offset(0, 1).Value = 1
Else:
Target.Offset(0, 1).Value = 0
End If
End If
End Sub
The problem occurs when I try to clear the cells in column A.
When I select the cells I want to clear and press "Delete" I get "Run-time error '13' - Type mismatch" on the line "IF Target.Value = 1".
I would also like the cells in the B column to be cleared if I clear cells in the A column. E.g. if I delete cell A2:A5, B2:B5 should be cleared.
From what I understand the problem is that when selecting multiple cells it returns an array as the Target, and this is a mismatch with the Integer.
Is there a way around this problem?
Try this. You need to cater for multiple cells in some way, for the reasons you mention, and add an extra clause to your If.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, r1 As Range
Set r = Intersect(Target, Range("A1:A10"))
If Not r Is Nothing Then
For Each r1 In r
If r1.Value = 1 Then
r1.Offset(0, 1).Value = 1
ElseIf r1.Value = vbNullString Then
r1.Offset(0, 1).Value = vbNullString
Else
r1.Offset(0, 1).Value = 0
End If
Next r1
End If
End Sub
In a first step we add the functionality that multiple cells are selected and changed:
Private Sub Worksheet_Change_Var1(ByVal Target As Range)
Dim targetCell As Range
'If Target.Range.count
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
If Target.Cells.Count > 1 Then
For Each targetCell In Target
If targetCell.Value = 1 Then
targetCell.Offset(0, 1).Value = 1
Else
targetCell.Offset(0, 1).Value = 0
End If
Next targetCell
Else
If Target.Value = 1 Then
Target.Offset(0, 1).Value = 1
Else
Target.Offset(0, 1).Value = 0
End If
End If
End If
End Sub
In the 2nd step we understand that also the "one cell" case can be handled in the same way and we add an if clause for the "cell(s) cleared" case:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim targetCell As Range
'If Target.Range.count
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
For Each targetCell In Target
If targetCell.Value = 1 Then
targetCell.Offset(0, 1).Value = 1
Else
targetCell.Offset(0, 1).Value = 0
End If
'if cell in col A is empty, then clear cell in col B
If targetCell.Value = "" Then targetCell.Offset(0, 1).ClearContents
Next targetCell
End If
End Sub
Advice would be gratefully appreciated. I am developing a spreadsheet using Excel 2016/Windows.
I have written 4 eventchange subroutines and all work well. The VBA Code for a worksheet checks for 4 events. Event 1, 2 and 3 enter today's date in a cell if data is entered in another cell (code not included below)
Code for EventChange works fine, but sometimes works when not expected to!
EventChange4 moves a value from one cell to another if another cell contains the text in Column J is "THIS Month – Payment Due" or "Issued But Not Paid. The second part of this eventchange4 moves a zero value to 2 cells if the data in column j contains text "not going ahead"
I am new to VBA. The problem is that eventchange4 runs for no apparent reason, e.g. copying a cell value in column H down to another cell in column h. How can I modify the code such that that eventchange4 only runs when the data in Column J Changes??? All advice gratefully accepted!!!!
Private Sub Worksheet_Change(ByVal Target As Range)
Call EventChange_1(Target)
Call EventChange_2(Target)
Call EventChange_3(Target)
Call EventChange_4(Target)
End Sub
Sub EventChange_1(ByVal Target As Range)
'Update on 11/11/2019 -If data changes in column L, insert
'today's date into column M
End Sub
Sub EventChange_2(ByVal Target As Range)
'Update on 15/01/2020 -If data changes in column P, insert today's date
'into next Column Q
End Sub
Sub EventChange_3(ByVal Target As Range)
'Update on 15/01/2020 -If data changes in column R, insert today's date
'into next Column S
End Sub
Sub EventChange_4(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
' this works !
If Target.Column = 10 And (Target.Value = "THIS Month – Payment Due" Or Target.Value = "Issued But Not Paid") Then
Range("K" & Target.Row).Value = Range("I" & Target.Row).Value
Range("I" & Target.Row).Clear
MsgBox "Moved Commission Due to Month Paid"
End If
If Target.Column = 10 And (Target.Value = "Not Going Ahead") Then
Range("I" & Target.Row).Value = 0
Range("K" & Target.Row).Value = 0
MsgBox "Moved ZERO to Initial Commisson and Month Paid"
End If
Application.EnableEvents = True
End Sub
Ideally you should update your code so it can properly handle a Target range which is not just a single cell:
Sub EventChange_4(ByVal Target As Range)
Dim rng As Range, c As Range, v
'any part of Target in Column J?
Set rng = Application.Intersect(Target, Me.Columns(10))
If Not rng Is Nothing Then
'have some cells to process...
On Error GoTo haveError
Application.EnableEvents = False
'process each affected cell in Col J
For Each c In rng.Cells
v = c.Value
If v = "THIS Month – Payment Due" Or v = "Issued But Not Paid" Then
Range("K" & c.Row).Value = Range("I" & c.Row).Value
Range("I" & c.Row).Clear
MsgBox "Moved Commission Due to Month Paid"
End If
If v = "Not Going Ahead" Then
Range("I" & c.Row).Value = 0
Range("K" & c.Row).Value = 0
MsgBox "Moved ZERO to Initial Commisson and Month Paid"
End If
Next c
End If
haveError:
Application.EnableEvents = True
End Sub
NOTE: this is assumed to be in the relevant worksheet code module - otherwise you should qualify the Range() calls with a specific worksheet reference.
All your "change" handlers should follow a similar pattern.
Tim apologies. I am new to this and was anxious to get a solution. Thank you for your response. Advice Noted. T
When I attempt to insert or delete a row in the spreadsheet, the VBA code identifies a worksheet event and attempts to run the code. The spreadsheet crashes. I have attempted to add code that will prevent this by checking at the beginning of the module if a row has been inserted or deleted before the other worksheet change event if statements are checked
Thank you
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aCell As Range
Dim wsInc As Worksheet
Dim count As Integer
Dim lRow As Long
Dim ans As Variant
Dim tb As ListObject
On Error GoTo Whoa
Application.EnableEvents = False
Set tb = ActiveSheet.ListObjects(1)
MsgBox Target.Rows.count
If tb.Range.Cells.count > count Then
count = tb.Range.Cells.count
' GoTo Whoa
ElseIf tb.Range.Cells.count < count Then
count = tb.Range.Cells.count
' GoTo Whoa
'~~> Check if the change happened in Col A
ElseIf Not Intersect(Target, Columns(1)) Is Nothing Then
For Each aCell In Target.Cells
With aCell
If Len(Trim(.Value)) = 0 Then
.Offset(, 1).ClearContents
Else
.Offset(, 1).NumberFormat = "dd/mm/yyyy"
.Offset(, 1).Value = Now
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End With
Next
'~~> Check if the change happened in Col L
ElseIf Not Intersect(Target, Columns(12)) Is Nothing Then
Set wsInc = Sheets("Income")
lRow = wsInc.Range("A" & wsInc.Rows.count).End(xlUp).Row + 1
For Each aCell In Target.Cells
With aCell
If Len(Trim(.Value)) = 0 Then
.Offset(, 1).ClearContents
Else
.Offset(, 1).NumberFormat = "dd/mm/yyyy"
.Offset(, 1).Value = Now
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'~~> Check of the value is Fees Received, Policy No. Issued
If .Value = "Fees Received" Or .Value = "Policy No. Issued" Then
ans = MsgBox("Do you want to copy this client to the Income Worksheet?", vbQuestion + vbYesNo)
If ans = False Then Exit For
wsInc.Range("A" & lRow).Value = Range("A" & aCell.Row).Value
End If
End If
End With
Next
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
I'm trying to add columns (or delete them if the number is reduced) between where "ID" and "Total" are based on the cell value in B1.
How could this be done automatically every time the cell is updated?
Code I have so far
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("B1")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
Dim i As Integer
For i = 1 To Range("B1").Value
Columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Next i
End If
End Sub
There are a number of issues in your code:
Unqualified range references refer to a default sheet object. While it won't be a problem in this instance (in a worksheet code behind module that object is sheet sheet containing the code, in any other module its the Activesheet), it's a bad habit to get into. Use the keyword Me to refer to the sheet the code is in.
When changing the sheet in a Worksheet_Change event, use Application.EnableEvents = False to prevent an event cascade (any time the code changes the sheet the event is called again)
Use an Error Handler to turn it back on (Application.EnableEvents = True)
Calculate how many columns to Insert or Delete based on existing columns
Range check the user input to ensure it's valid
Insert or delete in one block
On the assumption the "Totals" column contains a formula to sum the row (eg for 2 columns, row 4 it might be =Sum($C4:$D4), when you insert columns at column C the formula won't include the new columns. The code can update the formulas if required.
Target is already a range. No need to get its address as a string, then turn it back into a range, use it directly
Your code, refactored:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim NumColumnsRequired As Long
Dim NumExistingColumns As Long
Dim NumToInsertOrDelete As Long
Dim TotalsRange As Range
On Error GoTo EH
Set KeyCells = Me.Range("B1")
If Not Application.Intersect(KeyCells, Target) Is Nothing Then
' Validate Entry
If Not IsNumeric(KeyCells.Value) Then Exit Sub
NumColumnsRequired = KeyCells.Value
If NumColumnsRequired <= 0 Or NumColumnsRequired > 16380 Then Exit Sub
Application.EnableEvents = False
NumExistingColumns = Me.Cells(3, Me.Columns.Count).End(xlToLeft).Column - 3
NumToInsertOrDelete = NumColumnsRequired - NumExistingColumns
Select Case NumToInsertOrDelete
Case Is < 0
' Delete columns
Me.Columns(3).Resize(, -NumToInsertOrDelete).Delete
Case Is > 0
' Insert columns
Me.Columns(3).Resize(, NumToInsertOrDelete).Insert CopyOrigin:=xlFormatFromLeftOrAbove
'Optional: update Total Formulas
Set TotalsRange = Me.Cells(Me.Rows.Count, Me.Cells(3, Me.Columns.Count).End(xlToLeft).Column).End(xlUp)
If TotalsRange.Row > 3 Then
Set TotalsRange = Me.Range(TotalsRange, Me.Cells(4, TotalsRange.Column))
TotalsRange.Formula2R1C1 = "=Sum(RC3:RC" & TotalsRange.Column - 1 & ")"
End If
Case 0
' No Change
End Select
End If
EH:
Application.EnableEvents = True
End Sub
may try the code below to have the result like
code is more or less self explanatory
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range, ColNum As Long, TotalCol As Long, LeftFixedCol As Long
Dim Rng As Range, c As Range
Set KeyCells = Range("B1")
If Application.Intersect(KeyCells, Target) Is Nothing Then Exit Sub
If IsNumeric(KeyCells.Value) = False Then Exit Sub
ColNum = KeyCells.Value
If ColNum <= 0 Then Exit Sub
Set Rng = Range(Cells(3, 1), Cells(3, Columns.Count))
Set c = Rng.Find("Total") 'the find is case senseticve, Change "Total" to desired key word to find
If c Is Nothing Then Exit Sub
TotalCol = c.Column
LeftFixedCol = 2 'Column A & B for Company and ID
Dim i As Integer
If TotalCol < LeftFixedCol + ColNum + 1 Then ' Add column
For i = TotalCol To LeftFixedCol + ColNum
Columns(i).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(3, i).Value = "Column " & i - LeftFixedCol ' may not use this line
Next i
End If
If TotalCol > LeftFixedCol + ColNum + 1 Then ' Add column
For i = TotalCol - 1 To LeftFixedCol + ColNum + 1 Step -1
Columns(i).Delete
Next i
End If
End Sub
However to keep the Sum formula on total Column consistence with added column, may limit number of minimum columns to 2 and inserting columns in between existing columns, by changing following
If ColNum <= 1 Then Exit Sub
and
Columns(i - 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
also delete line inserting column heading
Cells(3, i).Value = "Column " & i - LeftFixedCol ' may not use this line
otherwise may add VBA code to change formula of total column to requirement.
You can try the following.
the named ranges are defined:
"B1" -> "ColumnNumber"
"B3" -> "Header.ID"
"F3" -> "Header.Total" (but it changes as you add / remove columns)"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim headerId As Range, headerTotal As Range, columnNumber As Range
Dim currentNumberOfColumns As Integer, targetNumberOfColumns As Integer
Dim columnsToAdd As Integer, columnsToRemove As Integer
Dim i As Integer
On Error GoTo error_catch
Application.EnableEvents = False
Set columnNumber = Me.Range("ColumnNumber")
If Not Application.Intersect(columnNumber, Target) Is Nothing Then
Set headerId = Me.Range("Header.ID")
Set headerTotal = Me.Range("Header.Total")
targetNumberOfColumns = columnNumber.Value
If targetNumberOfColumns <= 0 Then
Application.EnableEvents = True
Exit Sub
End If
currentNumberOfColumns = headerTotal.Column - headerId.Column - 1
Debug.Print "Currently there are " & currentNumberOfColumns & " columns"
If currentNumberOfColumns = targetNumberOfColumns Then
Application.EnableEvents = True
Exit Sub
Else
If targetNumberOfColumns > currentNumberOfColumns Then
columnsToAdd = targetNumberOfColumns - currentNumberOfColumns
Debug.Print "Need to add " & columnsToAdd & " columns"
For i = 1 To columnsToAdd
headerTotal.Offset(0, -1).EntireColumn.Select
Selection.Copy
headerTotal.EntireColumn.Select
Selection.Insert Shift:=xlToRight
Next i
Else
columnsToRemove = -(targetNumberOfColumns - currentNumberOfColumns)
Debug.Print "Need to remove " & columnsToRemove & " columns"
For i = 1 To columnsToRemove
headerTotal.Offset(0, -1).EntireColumn.Select
Selection.Delete Shift:=xlToLeft
Next i
End If
End If
End If
columnNumber.Select
Application.CutCopyMode = False
Application.EnableEvents = True
Exit Sub
error_catch:
MsgBox Err.Description
Application.EnableEvents = True
End Sub
I am very new to Excel VBA and I’m an trying to write some code that achieves the following:
When a cell is clicked in column A that contained the text “123” or “xyz” the cell in the same row but in column B records the current time, and the cell in the same row but in column C records the username of the person who clicked it.
The following is the code I am currently using:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim RowNum As Long
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column <> 1 Then Exit Sub
If Not Target.Value.Text = 123 Then Exit Sub
If Not Target.Value.Text = XYZ Then Exit Sub
RowNum = Target.Row
Range("B" & RowNum).Value = Date
Range("C" & RowNum).Value = Environ("UserName")
End Sub
Currently I a variable not defined error on XYZ, however I feel as if there is quite a lot of other issues with my code.
You were not too far. I think this should work fine:
Private Sub Worksheet_Change(ByVal Target As Range) '<-- event is change, non selection change
Dim RowNum As Long
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column <> 1 Then Exit Sub
If (Target.Value = "123") Or (Target.Value = "xyz") Then '<-- if the value is either "xyz" or "123"
RowNum = Target.Row
Range("B" & RowNum).Value = Now() '<-- current time in column B
Range("C" & RowNum).Value = Environ("UserName") '<-- username in column C
End If
End Sub