Replace cell values with a link to the data validation list automatically

In Excel the Data validation with a reference to a given list of choices is a great feature to simplify data entries with in-cell drop-down menus. However if any of the items in the validation list gets renamend, or changed later on, the entries in the worksheet don’t get updated since no link is present. This can be overcome by replacing the static cell value with a link to the validation list. This can be automated by using the Worksheet change event.

Microsoft Excel Object Worksheet

Option Explicit 
 
Private Sub Worksheet_Change(ByVal Target As Range) 
'———————————————————————————————————————————————————————————————————————————————————— 
' 1. entries in this sheet are being replaced with a link to the validation list 
    Call replace_cell_entry_with_link(Target) 

End Sub

Std. Code Module

Option Explicit 
 
Sub replace_cell_entry_with_link(ByVal Target As Range) 
' for cells with data validation based on lists it replaces the selected entry from the list with a link to the selected list item 
' being called by the "Worksheet_Change"-Event set-up in the code mdule of the relevant worksheet objects 
   Dim c As Range, lnkCell As Range 
   Dim s As String, f As String 
   With Application 
      .EnableEvents = False 
      .ScreenUpdating = False 
      On Error GoTo nextone 
      For Each c In Target.Cells 
         If c.Validation.Type = xlValidateList Then  ' xlValidateList=3 see http://msdn.microsoft.com/en-us/library/office/ff840715(v=office.15).aspx 
            s = c.Formula  'the actual value that has been entered in the cell 
            If s <> "" And Left(s, 1) <> "=" Then   ' if not empty or a formula 
               f = Mid(c.Validation.Formula1, 2)   ' we need the validation string without the "=" sign 
               If Application.ReferenceStyle = xlR1C1 Then   'we convert if required 
                  f = Application.ConvertFormula(f, fromreferencestyle:=xlR1C1, toreferencestyle:=xlA1) 
               End If 
               ' now 2 attempts to get the cell adress of the list item in the validation list 
               Set lnkCell = Application.Range(f).Find(c.Value, LookIn:=xlValues, LookAt:=xlWhole) 
               If lnkCell Is Nothing Then 
                  Set lnkCell = Application.Range(f).Find(c.Value, LookIn:=xlFormulas, LookAt:=xlWhole) 
               End If 
 
               If Not lnkCell Is Nothing Then  ' address has been found 🙂 
                  With lnkCell.Worksheet 
                     c.Formula = "='" & .Name & "'!" & lnkCell.Address 
                     c.Font.ColorIndex = 14 
                  End With 
                  Set lnkCell = Nothing 
               End If 
            End If 
         End If 
nextone: 
      Next c 
      .EnableEvents = True 
      .ScreenUpdating = True 
   End With 
End Sub