Link 2 Data Validation Cells - excel

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

Related

Restricting duplicate values in Excel VBA

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

Conflict between two events if Filtermode = False and any cells changed by Fill handle. Error raised (Method 'Undo' of object 'Application' failed)?

I have two codes depend on application events to run.
Code (1) change color of column_A If FilterMode is True on any column of ActiveSheet.
Code (2) Log changes of any cells in ActiveSheet and put in another sheet("Log").
Error raised if : Filtermode = False and any cells changed by fill handle (the small square in the lower-right corner of the selected cell) ,
I got this error
Method 'Undo' of object '_Application' failed
on this line Application.Undo on Code (2).
I tried to use to disable and enable events with code (1) with no luck.
any help will be appreciated.
Option Compare Text
Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
'Code (1) change color of column_A If FilterMode is True on any column of active sheet.
Dim Column_A As Range
Set Column_A = ActiveSheet.Range("A3", ActiveSheet.Range("A" & ActiveSheet.Rows.count).End(xlUp))
If ActiveSheet.FilterMode = True Then
Column_A.Interior.Color = RGB(196, 240, 255)
Else 'FilterMode = False
Column_A.Interior.Color = RGB(255, 255, 255)
End If
End Sub
' Code (2) Log Changes of Current Sheet and put in Sheet("Log")
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue
Dim sh As Worksheet: Set sh = Sheets("Log")
Dim UN As String: UN = Environ$("username")
If Not Intersect(Target, Range("AK:XFD")) Is Nothing Then Exit Sub 'not doing anything if a cell in "AK:XFD" is changed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Target.Cells.count > 1 Then
TgValue = extractData(Target)
Else
TgValue = Array(Array(Target.value, Target.Address(0, 0))) 'put the target range in an array (or as a string for a single cell)
boolOne = True
End If
Application.EnableEvents = False 'Avoide trigger the change event after UnDo
Application.Undo
RangeValues = extractData(Target) 'Define RangeValue
putDataBack TgValue, ActiveSheet 'Reinsert changed data
If boolOne Then Target.Offset(1).Select
Application.EnableEvents = True
Dim columnHeader As String, rowHeader As String
For r = 0 To UBound(RangeValues)
If RangeValues(r)(0) <> TgValue(r)(0) Then
columnHeader = Cells(1, Range(RangeValues(r)(1)).Column).value
rowHeader = Range("B" & Range(RangeValues(r)(1)).Row).value
Sheets("Log").Range("A" & Rows.count).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
Array(UN, Now, rowHeader, columnHeader, TgValue(r)(0), RangeValues(r)(0))
'Array("User Name", "Date,Time", "Work Order", "Column Label", "New Value", "Old Value")
Range(RangeValues(r)(1)).EntireRow.AutoFit
If Range(RangeValues(r)(1)).RowHeight < 53 Then
Range(RangeValues(r)(1)).RowHeight = 53
End If
End If
Next r
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub putDataBack(arr, sh As Worksheet)
Dim i As Long, arrInt, El
For Each El In arr
sh.Range(El(1)).value = El(0)
Next
End Sub
Function extractData(rng As Range) As Variant
Dim a As Range, arr, count As Long, i As Long
ReDim arr(rng.Cells.count - 1)
For Each a In rng.Areas 'creating a jagged array containing the values and the cells address
For i = 1 To a.Cells.count
arr(count) = Array(a.Cells(i).value, a.Cells(i).Address(0, 0)): count = count + 1
Next
Next
extractData = arr
End Function
I figured out the issue, although the error rising with code (2) Worksheet_Change event ,
But actually SelectionChange event on code(1) is the real problem.
Apparently, when I drag down, it is sort of like selecting cells individually and all of them at the same time.
To solve this issue, a condition must be added to event SelectionChange to count the target cells:
If Target.Cells.CountLarge = 1 then
So I just modified the code to look like this in the SelectionChange part and it now works perfectly.
'Code (1)
Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
If Target.Cells.CountLarge = 1 Then
Dim Column_A As Range
Set Column_A = ActiveSheet.Range("A3", ActiveSheet.Range("A" & ActiveSheet.Rows.count).End(xlUp))
If ActiveSheet.FilterMode = True Then
Column_A.Interior.Color = RGB(255, 0, 0)
Else 'FilterMode = False
Column_A.Interior.Color = RGB(255, 255, 255)
End If
End If
End Sub
In the meantime, I learned that Calculate event would be best choice to trapping a change to a filtered list as described on this link
https://www.experts-exchange.com/articles/2773/Trapping-a-change-to-a-filtered-list-with-VBA.html

Update excel cell with date if a cell in a range is update

I need to update a cell with the date and time stamp (NOW()) if any cell is updated within any cell before it within that same row.
So update cell "CU" with date and time when any cell from "A-CR" is updated.
I have done some searching but I can only seem to find bits that work if only updating a single cell, I'm looking for if anything changes within that range.
I currently have some Vba which does something similar which will update the adjacent cell with time and date which is required but I also need an overall one for the whole process.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F:F, I:I, L:L, O:O, R:R, U:U, X:X, AA:AA, AB:AB, AE:AE, AH:AH, AK:AK, AN:AN, AQ:AQ, AT:AT, AW:AW, AZ:AZ, BC:BC, BF:BF, BI:BI, BL:BL, BO:BO, BR:BR, BU:BU, BX:BX, CA:CA, CD:CD, CG:CG, CJ:CJ, CM:CM, CP:CP")) Is Nothing Then
On Error GoTo safe_exit
With Application
.EnableEvents = False
.ScreenUpdating = False
Dim trgt As Range, ws1 As Worksheet
'Set ws1 = ThisWorkbook.Worksheets("Info")
For Each trgt In Intersect(Target, Range("F:F, I:I, L:L, O:O, R:R, U:U, X:X, AA:AA, AB:AB, AE:AE, AH:AH, AK:AK, AN:AN, AQ:AQ, AT:AT, AW:AW, AZ:AZ, BC:BC, BF:BF, BI:BI, BL:BL, BO:BO, BR:BR, BU:BU, BX:BX, CA:CA, CD:CD, CG:CG, CJ:CJ, CM:CM, CP:CP"))
If trgt <> vbNullString Then
If UCase(trgt.Value) = "Y" Or UCase(trgt.Value) = "N" Then
Cells(trgt.Row, trgt.Column + 1) = Now()
Cells(trgt.Row, trgt.Column + 2) = Environ("username")
'Select Case trgt.Column
' Case 2 'column B
' Cells(trgt.Row, trgt.Column + 1) = Environ("username")
' Case 4 'column D
' 'do something else
' End Select
Else
trgt = ""
Cells(trgt.Row, trgt.Column + 1) = ""
Cells(trgt.Row, trgt.Column + 2) = ""
End If
End If
Next trgt
'Set ws1 = Nothing
End With
End If
safe_exit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
This works for me:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Intersect(Target, Me.Range("A" & Target.Row & ":CR" & Target.Row)) Is Nothing Then GoTo SafeExit
Me.Cells(Target.Row, "CU") = Now()
SafeExit:
Application.EnableEvents = True
End Sub
The below code takes care of:
Clearing the time if the row is blank.
Updating the time only if the values really change from the previous value.
Dim oldValue As String
'Change the range below where your data will be
Const RangeString = "A:CR"
'Below variable decides the column in which date will be displayed
'Change the below value to 1 for column A, 2 for B, ... 99 for CU
Const ColumnIndex = 99
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WorkRng As Range
Dim HorizontalRng As Range
Dim Rng As Range
Dim HorRng As Range
Dim RowHasVal As Boolean
Set WorkRng = Intersect(ActiveSheet.Range(RangeString), Target)
If Not WorkRng Is Nothing Then
If WorkRng.Cells.Count = 1 And WorkRng.Cells(1, 1).Value = oldValue Then
Exit Sub
End If
Application.EnableEvents = False
For Each Rng In WorkRng
Set HorizontalRng = Intersect(ActiveSheet.Range(RangeString), Rows(Rng.Row))
RowHasVal = False
For Each HorRng In HorizontalRng
If Not VBA.IsEmpty(HorRng.Value) Then
RowHasVal = True
Exit For
End If
Next
If Not RowHasVal Then
ActiveSheet.Cells(Rng.Row, ColumnIndex).ClearContents
ElseIf Not VBA.IsEmpty(Rng.Value) Then
ActiveSheet.Cells(Rng.Row, ColumnIndex).Value = Now
ActiveSheet.Cells(Rng.Row, ColumnIndex).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
End If
Next
Application.EnableEvents = True
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, ActiveSheet.Range(RangeString)) Is Nothing Then
If Target.Cells.Count = 1 Then
oldValue = Target.Value
Else
oldValue = ""
End If
End If
End Sub

Excel 2 Worksheets Events with Different Targets

I have an excel worksheet that I want to assign to it more than one Worksheet Event.
To be more specific, I want whenever a cell in column B is changed then one cell to the left (column A) gets the row number.
Also I want whenever a cell in column J is changed then one cell to the right (column K) gets today's date.
It worked for me for both of them individually but I think I may be doing something wrong using them together.
Any help will be much appreciated!
Private Sub AG1(ByVal a_Target As Range)
If Not Intersect(a_Target, Me.Range("B2:B3000")) Is Nothing Then
Application.EnableEvents = False
Cells(a_Target.Row, a_Target.Column - 1) = a_Target.Row
Application.EnableEvents = True
End If
End Sub
Private Sub AG2(ByVal b_Target As Range)
If Not Intersect(b_Target, Me.Range("J2:J3000")) Is Nothing Then
Application.EnableEvents = False
Cells(b_Target.Row, b_Target.Column + 1) = Date
Application.EnableEvents = True
End If
End Sub
edit - works now (I also added that column can be referred as letter):
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = True
If Split(Cells(1, Target.Column).Address(True, False), "$")(0) = "B" Then
Application.EnableEvents = False
Cells(Target.Row, Target.Column - 1) = Target.Row
Application.EnableEvents = True
ElseIf Split(Cells(1, Target.Column).Address(True, False), "$")(0) = "J" Then
Application.EnableEvents = False
Cells(Target.Row, Target.Column + 1) = Date
Application.EnableEvents = True
End If
End Sub
Copy the code in the Worksheet_Change event and that should fix your issue. This will trigger every time you enter a value for any cell and will only meet the condition if they intersect the range in the if statement.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("B2:B3000")) Is Nothing Then
Application.EnableEvents = False
Cells(Target.Row, Target.Column - 1) = Target.Row
Application.EnableEvents = True
End If
If Not Intersect(Target, Me.Range("J2:J3000")) Is Nothing Then
Application.EnableEvents = False
Cells(Target.Row, Target.Column + 1) = Date
Application.EnableEvents = True
End If
End Sub

Ambiguous name detected: Worksheet_change

I'm attempting to add a second code to a single worksheet and keep getting the "Ambiguous name detected" error. Realise that I need to combine the two codes but having trouble doing so. here are the two codes, one below the other:
Private Sub Worksheet_Change(ByVal Target As Range)
'are changes made within answer range?
Set isect = Application.Intersect(Target, Range("Answers"))
If Not (isect Is Nothing) Then
For Each chng In Target.Cells
'Get row number
startY = Impact.Range("Answers").Row
targetY = chng.Row
row_offset = (targetY - startY) + 1
rating_type = Impact.Range("Impacts").Cells(row_offset, 1)
If rating_type = "Major / V.High" Then cols = 16711884
If rating_type = "Significant / High" Then cols = 255
If rating_type = "Important / Moderate" Then cols = 49407
If rating_type = "Minor / Low" Then cols = 5287936
If rating_type = "" Then cols = 16777215
Impact.Range("Ratings").Cells(row_offset, 1).Interior.Color = cols
Impact.Range("Impacts").Cells(row_offset, 1).Interior.Color = cols
Next chng
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
' To Select Multiple Items from a Drop Down List in Excel
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.Address = "$C$2" Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else: If Target.Value = "" Then GoTo Exitsub Else
Application.EnableEvents = False
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
If Oldvalue = "" Then
Target.Value = Newvalue
Else
If InStr(1, Oldvalue, Newvalue) = 0 Then
Target.Value = Oldvalue & ", " & Newvalue
Else:
Target.Value = Oldvalue
End If
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
Was hoping someone knows how to combine the two in order to circumvent this error.
Thanks in advance!
Based on my comment, you can track changes in more than one range as shown in the below sample code.
Private Sub Worksheet_Change(ByVal Target As Range)
'Exit the sub if more than one cells are changed at the same time
If Target.CountLarge > 1 Then Exit Sub
'Disable the event so that if the code changes the cell content of any cell, the code is not triggered again
Application.EnableEvents = False
'Error handling to skip the code if an error occurs during the code execution and enable the events again
On Error GoTo ErrorHandling
'Change event code will be triggered if any cell in column A is changed
If Not Intersect(Target, Range("A:A")) Is Nothing Then
MsgBox "The content of a cell in colunm A has been changed."
'Change event code will be triggered if any cell in column C is changed
ElseIf Not Intersect(Target, Range("C:C")) Is Nothing Then
MsgBox "The content of a cell in colunm C has been changed."
'Change event code will be triggered if any cell in column E is changed
ElseIf Not Intersect(Target, Range("E:E")) Is Nothing Then
MsgBox "The content of a cell in colunm E has been changed."
End If
ErrorHandling:
Application.EnableEvents = True
End Sub

Resources