Option Explicit
 Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim ws As Worksheet
Dim str As String
Dim i As Integer
Dim rngDV As Range
Dim rng As Range
Dim strMsg As String
Dim lRsp As Long
strMsg = "Add this item to the list?"
 If Target.Count > 1 Then Exit Sub
Set ws = Worksheets("Lists")
 
If Target.Row > 1 Then
  On Error Resume Next
  Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
  On Error GoTo 0
  If rngDV Is Nothing Then Exit Sub
 
  If Intersect(Target, rngDV) Is Nothing Then Exit Sub
  If Target = "" Then Exit Sub
 
  str = Target.Validation.Formula1
  str = Right(str, Len(str) - 1)
  On Error Resume Next
  Set rng = ws.Range(str)
  On Error GoTo 0
  If rng Is Nothing Then Exit Sub
 
  If Application.WorksheetFunction _
    .CountIf(rng, Target.Value) Then
    Exit Sub
  Else
   lRsp = MsgBox(strMsg, vbQuestion + vbYesNo, "Add New Item?")
   If lRsp = vbYes Then
    i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1
    ws.Cells(i, rng.Column).Value = Target.Value
    rng.Sort Key1:=ws.Cells(1, rng.Column), _
      Order1:=xlAscending, Header:=xlNo, _
      OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom
    End If
  End If
 End If
 End Sub
 Private Sub TempCombo_KeyDown(ByVal _
        KeyCode As MSForms.ReturnInteger, _
        ByVal Shift As Integer)
 
On Error Resume Next
Dim ws As Worksheet
Dim str As String
Dim i As Integer
Dim rngDV As Range
Dim rng As Range
Dim strMsg As String
Dim lRsp As Long
Dim c As Range
strMsg = "Add this item to the list?"
 Set ws = Worksheets("Lists")
Set c = ActiveCell
 
  str = c.Validation.Formula1
  str = Right(str, Len(str) - 1)
  On Error Resume Next
  Set rng = ws.Range(str)
  On Error GoTo 0
  If rng Is Nothing Then Exit Sub
 
    Select Case KeyCode
        Case 9
            c.Offset(0, 1).Activate
              If c.Value = "" Then Exit Sub
               If Application.WorksheetFunction _
                  .CountIf(rng, c.Value) Then
                  Exit Sub
                Else
                 lRsp = MsgBox(strMsg, vbQuestion + vbYesNo, "Add New Item?")
                 If lRsp = vbYes Then
                  i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1
                  ws.Cells(i, rng.Column).Value = c.Value
                  rng.Sort Key1:=ws.Cells(1, rng.Column), _
                    Order1:=xlAscending, Header:=xlNo, _
                    OrderCustom:=1, MatchCase:=False, _
                    Orientation:=xlTopToBottom
                  End If
                End If
         Case 13
            c.Offset(1, 0).Activate
              If c.Value = "" Then Exit Sub
              If Application.WorksheetFunction _
                  .CountIf(rng, c.Value) Then
                  Exit Sub
                Else
                 lRsp = MsgBox(strMsg, vbQuestion + vbYesNo, "Add New Item?")
                 If lRsp = vbYes Then
                  i = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row + 1
                  ws.Cells(i, rng.Column).Value = c.Value
                  rng.Sort Key1:=ws.Cells(1, rng.Column), _
                    Order1:=xlAscending, Header:=xlNo, _
                    OrderCustom:=1, MatchCase:=False, _
                    Orientation:=xlTopToBottom
                  End If
                End If
        Case Else
            'do nothing
    End Select
 End Sub
 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Dim wsList As Worksheet
Dim rng As Range
Dim i As Integer
Dim strMsg As String
Dim lRsp As Long
Set ws = ActiveSheet
Set wsList = Sheets("Lists")
Set cboTemp = ws.OLEObjects("TempCombo")
strMsg = "Add this item to the list?"
 If Target.Count > 1 Then GoTo exitHandler
   On Error Resume Next
  With cboTemp
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
  End With
On Error GoTo errHandler
  If Target.Validation.Type = 3 Then
    Application.EnableEvents = False
    str = Target.Validation.Formula1
    str = Right(str, Len(str) - 1)
    With cboTemp
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 15
      .Height = Target.Height + 5
      .ListFillRange = str
      .LinkedCell = Target.Address
    End With
 
    cboTemp.Activate
  End If
 
exitHandler:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  Exit Sub
errHandler:
  Resume exitHandler
 End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        If Not Target.Comment Is Nothing Then
            With Target.Comment.Shape
                .Left = Target.Left - .Width - 10
                .Top = Target.Offset(1).Top
            End With
        End If
    End If
End Sub