Insert value based on drop down list from cell next to matched one - excel

Question

I have a sample table (B2:C4) with a couple of defined values "XXX = 10, YYY = 20, ZZZ = 30".
I have the second table (E2:F10) with drop down list in the column "E".
I need to copy value based on drop down list to column "F". It means for example when I select E3 = "XXX" from drop down list it copies appropriate value from column "C". In the example on the attached picture B1 = "XXX" -> C1 = "10" so the value will be copied to F3).
The problem is that the drop down list includes also another items than in the column "B2:B4" so I can customize the entry in the table.
I created working code but the issue is when I change any value in the column C2:C4 the value in the column F2:F10 does not change.
Any help would be appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Res As Variant
If Target.CountLarge > 1 Then Exit Sub
If Not Intersect(Target, Range("E2:E10")) Is Nothing Then
Res = Evaluate("INDEX(C2:C4,MATCH(" & Target.Address & ",B2:B4,0))")
If Not IsError(Res) Then Target.Offset(, 1) = Res
End If
End Sub
Sample XLSM file
This is how I edited the sample table and the code according #Variatus:
The module code:
Enum Nws ' worksheet where 'Data' values are used
' 060
NwsFirstDataRow = 7 ' change to suit
NwsTrigger = 6 ' Trigger column (5 = column E)
NwsTarget = 8 ' Target column (no value = previous + 1)
End Enum
Enum Nta ' columns of range 'Data'
' 060
NtaId = 1
NtaVal = 3
End Enum
And the sheet code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' 060
Dim Ws As Worksheet ' the sheet on which the "Data" range resides
Dim Rng As Range
Dim Tmp As Variant
' skip action if more than 1 cell was changed
If Target.CountLarge > 1 Then Exit Sub
Set Rng = Range(Cells(NwsFirstDataRow, NwsTrigger), _
Cells(Rows.Count, NwsTrigger).End(xlUp))
If Not Application.Intersect(Target, Rng) Is Nothing Then
Set Ws = ThisWorkbook.Sheets("test") ' change to match your facts
Set Rng = Ws.Range("B2:D4") ' change to match your facts
With Application
Tmp = .VLookup(Target.Value, Rng, 3, False)
If Not IsError(Tmp) Then
.EnableEvents = False ' suppress 'Change' event
Cells(Target.Row, NwsTarget).Value = Tmp
.EnableEvents = True
End If
End With
End If
' skip action if more than one cell was changed
If Target.CountLarge > 1 Then Exit Sub
If Not Application.Intersect(Target, Rng.Columns(NtaVal)) Is Nothing Then
UpdateCategory Target.Offset(0, -1).Resize(, 2).Value
End If
End Sub
Private Sub Worksheet_Deactivate()
' 060
Dim TgtWs As Worksheet ' the Tab on which 'Data' was used
Dim Cat As Variant ' 'Data' category (2 cells as Nta)
Dim R As Long ' loop counter: rows
Set TgtWs = ThisWorkbook.Sheets("test") ' change to match your facts
With Range("B2:D4") ' change to match your facts
For R = 1 To .Rows.Count
Cat = .Rows(R).Value
UpdateCategory Cat
Next R
End With
End Sub
Private Sub UpdateCategory(Cat As Variant)
' 060
Dim TgtWs As Worksheet ' the Tab on which 'Data' was used
Dim Fnd As Range ' matching cell
Dim FirstFound As Long ' row of first match
Dim Rng As Range
Set TgtWs = ThisWorkbook.Sheets("test") ' change to match your facts
Application.EnableEvents = False
With TgtWs
Set Rng = .Range(.Cells(NwsFirstDataRow, NwsTrigger), _
.Cells(.Rows.Count, NwsTrigger).End(xlUp))
With Rng
Set Fnd = .Find(Cat(1, NtaId), LookIn:=xlValues, LookAt:=xlWhole)
If Not Fnd Is Nothing Then
FirstFound = Fnd.Row
Do
TgtWs.Cells(Fnd.Row, NwsTarget).Value = Cat(1, NtaVal)
Set Fnd = .FindNext(Fnd)
If Fnd Is Nothing Then Exit Do
Loop While Fnd.Row <> FirstFound
End If
End With
End With
Application.EnableEvents = True
End Sub

Answer 1

The code below differs from the selected answer in the following respects.
All the action now takes place on one sheet, as per your original question. Therefore all the code must now be placed in one location, on the code sheet of the worksheet on which everything transpires. In consequence thereof all worksheet specification could be removed from the code.
An extra column was interjected in the Data range of which, however, only the first and third columns are used, as identified in the Enum Nta.
Option Explicit
Enum Nws ' worksheet where 'Data' values are used
' 060-2
NwsFirstDataRow = 2 ' change to suit
NwsTrigger = 5 ' Trigger column (5 = column E)
NwsTarget ' Target column (no value = previous + 1)
End Enum
Enum Nta ' columns of range 'Data'
' 060
NtaId = 1 ' 1st column of 'Data' range
NtaVal = 3 ' 3rd column of 'Data' range
End Enum
Private Sub Worksheet_Change(ByVal Target As Range)
' 060-2
Dim Rng As Range
Dim Tmp As Variant
' skip action if more than 1 cell was changed
If Target.CountLarge > 1 Then Exit Sub
Set Rng = Range(Cells(NwsFirstDataRow, NwsTrigger), _
Cells(Rows.Count, NwsTrigger).End(xlUp))
If Not Application.Intersect(Target, Rng) Is Nothing Then
With Application
Tmp = .VLookup(Target.Value, Range("Data"), NtaVal, False)
If Not IsError(Tmp) Then
.EnableEvents = False ' suppress 'Change' event
Cells(Target.Row, NwsTarget).Value = Tmp
.EnableEvents = True
End If
End With
Else
Set Rng = Range("Data") ' change to suit
If Not Application.Intersect(Target, Rng.Columns(NtaVal)) Is Nothing Then
UpdateCategory Cells(Target.Row, Rng.Column).Resize(1, NtaVal).Value
End If
End If
End Sub
Private Sub Worksheet_activate()
' 060-2
Dim TgtWs As Worksheet ' the Tab on which 'Data' was used
Dim Cat As Variant ' 'Data' category (2 cells as Nta)
Dim R As Long ' loop counter: rows
Set TgtWs = Sheet1 ' change to match your facts
With Range("Data") ' change to match your facts
For R = 1 To .Rows.Count
Cat = .Rows(R).Value
UpdateCategory Cat
Next R
End With
End Sub
Private Sub UpdateCategory(Cat As Variant)
' 060-2
Dim Fnd As Range ' matching cell
Dim FirstFound As Long ' row of first match
Dim Rng As Range
Application.EnableEvents = False
Set Rng = Range(Cells(NwsFirstDataRow, NwsTrigger), _
Cells(Rows.Count, NwsTrigger).End(xlUp))
With Rng
Set Fnd = .Find(Cat(1, NtaId), LookIn:=xlValues, LookAt:=xlWhole)
If Not Fnd Is Nothing Then
FirstFound = Fnd.Row
Do
Cells(Fnd.Row, NwsTarget).Value = Cat(1, NtaVal)
Set Fnd = .FindNext(Fnd)
If Fnd Is Nothing Then Exit Do
Loop While Fnd.Row <> FirstFound
End If
End With
Application.EnableEvents = True
End Sub

Answer 2

My answer could be improved if you use Excel Tables
Also some parts of the code could be refactored. For example you should add some error handling.
But, this should get you started:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim watchRange As Range
Dim cellFormula As String
' Define the watched range
Set watchRange = Me.Range("E2:E10")
' Do this for each cell changed in target
For Each cell In Target.Cells
' Check if cell is in watched range
If Not Intersect(cell, watchRange) Is Nothing Then
cellFormula = "=INDEX(C2:C4,MATCH(" & Target.Address & ",B2:B4,0))"
' Check if formula doesn't return an error (this could be imporoved?)
If Not IsError(cellFormula) Then
' Don't fire the change event twice
Application.EnableEvents = False
cell.Offset(, 1).Formula = cellFormula
Application.EnableEvents = False
End If
End If
Next cell
End Sub
Let me know if this is what you needed and if it works.

Answer 3

If you wish to maintain a permanent link between your table B2:C4 and the results in column F you need to establish a robust system for updating changes. In effect, column F must not only change with the selection in column E but also with updates in column C. Presuming that these data are on different sheets in your project different worksheet events must be captured and coordinated. To be safe you should also update all occasionally, such as on Workbook_Open or Worksheet_Activate in case an update was missed due to a system crash.
None of that is particularly difficult to program but Excel offers a solution without VBA that is so stunningly better that it can't be ignored. Here it is.
Create a named range C2:C4. I called it "Data" and made it dynamic so that it can expand without requiring my attention.
Use the first column of this range to feed the data validation drop-down: =INDEX(Data,,1)
Use this formula in column F, =VLOOKUP(E2,Data,2,FALSE)
All conditions laid out above are met.

Answer 4

I'm trying to make it simple. So here is the origin table from my answer above where I just extend Data range and values in the column "C" are now in the column "D". Everything works except when I change value in the column "D" nothing happens:
sample table extended
Module code:
Enum Nws ' worksheet where 'Data' values are used
' 060
NwsFirstDataRow = 2 ' change to suit
NwsTrigger = 5 ' Trigger column (5 = column E)
NwsTarget ' Target column (no value = previous + 1)
End Enum
Enum Nta ' columns of range 'Data'
' 060
NtaId = 1
NtaVal
End Enum
Test sheet code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' 060
Dim Ws As Worksheet ' the sheet on which the "Data" range resides
Dim Rng As Range
Dim Tmp As Variant
' skip action if more than 1 cell was changed
If Target.CountLarge > 1 Then Exit Sub
Set Rng = Range(Cells(NwsFirstDataRow, NwsTrigger), _
Cells(Rows.Count, NwsTrigger).End(xlUp))
If Not Application.Intersect(Target, Rng) Is Nothing Then
Set Ws = ThisWorkbook.Sheets("test") ' change to match your facts
Set Rng = Ws.Range("Data") ' change to match your facts
With Application
Tmp = .VLookup(Target.Value, Rng, 3, False)
If Not IsError(Tmp) Then
.EnableEvents = False ' suppress 'Change' event
Cells(Target.Row, NwsTarget).Value = Tmp
.EnableEvents = True
End If
End With
End If
' skip action if more than one cell was changed
If Target.CountLarge > 1 Then Exit Sub
If Not Application.Intersect(Target, Rng.Columns(NtaVal)) Is Nothing Then
UpdateCategory Target.Offset(0, -1).Resize(, 2).Value
End If
End Sub
Private Sub Worksheet_Deactivate()
' 060
Dim TgtWs As Worksheet ' the Tab on which 'Data' was used
Dim Cat As Variant ' 'Data' category (2 cells as Nta)
Dim R As Long ' loop counter: rows
Set TgtWs = ThisWorkbook.Sheets("test") ' change to match your facts
With Range("Data") ' change to match your facts
For R = 1 To .Rows.Count
Cat = .Rows(R).Value
UpdateCategory Cat
Next R
End With
End Sub
Private Sub UpdateCategory(Cat As Variant)
' 060
Dim TgtWs As Worksheet ' the Tab on which 'Data' was used
Dim Fnd As Range ' matching cell
Dim FirstFound As Long ' row of first match
Dim Rng As Range
Set TgtWs = ThisWorkbook.Sheets("test") ' change to match your facts
Application.EnableEvents = False
With TgtWs
Set Rng = .Range(.Cells(NwsFirstDataRow, NwsTrigger), _
.Cells(.Rows.Count, NwsTrigger).End(xlUp))
With Rng
Set Fnd = .Find(Cat(1, NtaId), LookIn:=xlValues, LookAt:=xlWhole)
If Not Fnd Is Nothing Then
FirstFound = Fnd.Row
Do
TgtWs.Cells(Fnd.Row, NwsTarget).Value = Cat(1, NtaVal)
Set Fnd = .FindNext(Fnd)
If Fnd Is Nothing Then Exit Do
Loop While Fnd.Row <> FirstFound
End If
End With
End With
Application.EnableEvents = True
End Sub

Answer 5

As promised above, the VBA solution is a lot more complicated than the one with VLOOKUP. But you can start in the same way. Create a named range where you store your "Categories" as I came to call them after I named the range "Data". This is a range with 2 columns, exactly as B2:C4 in your example. You can have this range on the same sheet as the action but I programmed in the assumption that it would be on another sheet.
Next, please install these enumerations in a standard code module. The first Enum identifies parts of the worksheet on which the range E:F of your example resides. It specifies row 2 as the first row with data, meaning row 1 will be omitted from scrutiny, and, in fact, assigns the job of columns 5 and 6, (E and F) of your example to the same columns in my code's output. You can change all of these values. The second enum identifies the columns of the 'Data' range. Naming these columns helps read the code. Changing the numbers makes no sense.
Enum Nws ' worksheet where 'Data' values are used
' 060
NwsFirstDataRow = 2 ' change to suit
NwsTrigger = 5 ' Trigger column (5 = column E)
NwsTarget ' Target column (no value = previous + 1)
End Enum
Enum Nta ' columns of range 'Data'
' 060
NtaId = 1
NtaVal
End Enum
The code below must be pasted to the code sheet of the worksheet on which you have the Data Validation drop-down. That is the one holding columns E:F of your example. Don't paste this code in the same module as the enumerations or any other standard code module. It must be the module assigned to the worksheet with these data. The code will check if an entry made in column E is present in 'Data' and get the value from there if it is. Else it will do nothing. Observe that this code needs to know where the category data are, worksheet and range name. I've marked the lines where you can change the specs.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' 060
Dim Ws As Worksheet ' the sheet on which the "Data" range resides
Dim Rng As Range
Dim Tmp As Variant
' skip action if more than 1 cell was changed
If Target.CountLarge > 1 Then Exit Sub
Set Rng = Range(Cells(NwsFirstDataRow, NwsTrigger), _
Cells(Rows.Count, NwsTrigger).End(xlUp))
If Not Application.Intersect(Target, Rng) Is Nothing Then
Set Ws = Sheet1 ' change to match your facts
Set Rng = Ws.Range("Data") ' change to match your facts
With Application
Tmp = .VLookup(Target.Value, Rng, 2, False)
If Not IsError(Tmp) Then
.EnableEvents = False ' suppress 'Change' event
Cells(Target.Row, NwsTarget).Value = Tmp
.EnableEvents = True
End If
End With
End If
End Sub
Finally, there is code to go into the worksheet on which you have the category data (B2:C4 in your example). This, too, must be the code sheet attached to that worksheet, not a standard code module. There is a procedure called Worksheet_Change which is the same as a corresponding procedure for the other sheet. Since there can't be two procedures of the same name in the same module these two procedures would have to be merged if you eventually need both the 'Data' and the validations on the same worksheet as you have them in your example. The code is laid out to have them on separate sheets.
Option Explicit
Private Sub Worksheet_Deactivate()
' 060
Dim TgtWs As Worksheet ' the Tab on which 'Data' was used
Dim Cat As Variant ' 'Data' category (2 cells as Nta)
Dim R As Long ' loop counter: rows
Set TgtWs = Sheet2 ' change to match your facts
With Range("Data") ' change to match your facts
For R = 1 To .Rows.Count
Cat = .Rows(R).Value
UpdateCategory Cat
Next R
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
' 060
Dim Ws As Worksheet ' the Tab on which 'Data' resides
Dim Rng As Range
' skip action if more than one cell was changed
If Target.CountLarge > 1 Then Exit Sub
Set Ws = Sheet1 ' change to suit
Set Rng = Ws.Range("Data") ' change to suit
If Not Application.Intersect(Target, Rng.Columns(NtaVal)) Is Nothing Then
UpdateCategory Target.Offset(0, -1).Resize(, NtaVal).Value
End If
End Sub
Private Sub UpdateCategory(Cat As Variant)
' 060
Dim TgtWs As Worksheet ' the Tab on which 'Data' was used
Dim Fnd As Range ' matching cell
Dim FirstFound As Long ' row of first match
Dim Rng As Range
Set TgtWs = Sheet2 ' change to match your facts
Application.EnableEvents = False
With TgtWs
Set Rng = .Range(.Cells(NwsFirstDataRow, NwsTrigger), _
.Cells(.Rows.Count, NwsTrigger).End(xlUp))
With Rng
Set Fnd = .Find(Cat(1, NtaId), LookIn:=xlValues, LookAt:=xlWhole)
If Not Fnd Is Nothing Then
FirstFound = Fnd.Row
Do
TgtWs.Cells(Fnd.Row, NwsTarget).Value = Cat(1, NtaVal)
Set Fnd = .FindNext(Fnd)
If Fnd Is Nothing Then Exit Do
Loop While Fnd.Row <> FirstFound
End If
End With
End With
Application.EnableEvents = True
End Sub
These three procedures work to maintain synch between the categories and the data, meaning, if a change occurs in the categories the data should reflect them. The key to this is the procedure UpdateCategory which looks for the category name in the data and ensures that it's the same as in the categories table. This procedure is called in two different ways.
One is when the value of a category is changed. It will then update that particular category. The other I have timed with the deactivation event of the worksheet. At that time all categories are updated, just in case an individual update has failed earlier. If you have a lot of data, or a lot of categories, this may prove slow. If so, there are ways to make it work faster.
I draw your attention to the need to specify both worksheets and the name of the 'Data' range in these procedures as well. The locations are marked. Please look for them.