Sorted Data Validation List on Another Sheet code very wordy.

Hello!

I have a clunky code which takes the value in cell C5 on SHEETB and uses it for a dropdown validation list from a named range on SHEETA.
If the C5 value is not on the dropdown, it asks you if you want to add it, so the next time you use that worksheet, you won't have to re-type that new value.

So as new values get added, the dropdown list grows and it does a sort so that the list is always in alphabetical order.

I'd appreciate it if someone can look at this code. I used the macro recorder alot, and this result works but it seems to me like some of the steps can be combined. And then I set the range to 10,000 entries so I'm not sure what's going to happen if there's 10,001 (will that one not get sorted?), etc.

Regards,
Leaning

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lReply As Long
On Error GoTo OrderlyExit
If Target.Cells.Count > 1 Then Exit Sub
If Target.Address = "$C$5" Then
If IsEmpty(Target) Then Exit Sub
Application.EnableEvents = False
If WorksheetFunction.CountIf(ThisWorkbook.Names("UnitInfo").RefersToRange, Target) = 0 Then
lReply = MsgBox("Add " & Target & " to list? (Note: Once it's there, you're stuck with it.)", vbYesNo + vbQuestion)
If lReply = vbYes Then
'Sheets("SheetA").Unprotect Password:="unprotect"
With ThisWorkbook.Names("UnitInfo").RefersToRange.Cells(ThisWorkbook.Names("UnitInfo").RefersToRange.Rows.Count, 1)
If Len(.Value) > 0 Then
.Offset(1, 0).Value = Target
Else
.Value = Target
End If
MsgBox (Target & " added to list.")
End With
'Sheets("SheetA").Protect Password:="protect"
End If
End If
Application.EnableEvents = True
End If
ActiveWorkbook.Sheets("SHEETA").Select
    ActiveWorkbook.Sheets("SHEETA").Columns("D:D").Select
    ActiveWorkbook.Worksheets("SHEETA").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("SHEETA").Sort.SortFields.Add Key:=Range("D1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("SHEETA").Sort
        .SetRange Range("D1:D10000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
  
End With
Sheets("SHEETB").Select
Range("C5").Select
OrderlyExit: Application.EnableEvents = True
End Sub

Skywriter: That's awesome! It works tons different and smoother without the screen flickering all over the place from changing sheets.
I appreciate your help. I think you chopped almost half the lines of code, so yeah, it needed some work. Mad props!

Regards,
Leaning

skywriter: the protect, unprotect, and VBA passwords are all "help". My actual project is locked so I wanted to see if maybe the lock was causing problems and creating that white space.

HTH.
Regards,
Leaning

skywriter: still not working on my end. Dropdown still has extra spaces. Any other ideas? I highlighted all the data cells purple, but it doesn't look like there is anything below that is making the dropdown list so long. I'm stumped. Thanks for sticking with me through this. And I updated my location. Thanks for that!

Regards,
Leaning

I kept getting blank lines in the dropdown using skywriter's code, so I'm back to my clunky code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lReply As Long
On Error GoTo OrderlyExit
If Target.Cells.Count > 1 Then Exit Sub
If Target.Address = "$C$20" Then
If IsEmpty(Target) Then Exit Sub
Application.EnableEvents = False
If WorksheetFunction.CountIf(ThisWorkbook.Names("UnitInfo").RefersToRange, Target) = 0 Then
lReply = MsgBox("Add " & Target & " to list? (Note: Once it's there, you're stuck with it.)", vbYesNo + vbQuestion)
If lReply = vbYes Then
Sheets("MyM").Unprotect Password:="help"
With ThisWorkbook.Names("UnitInfo").RefersToRange.Cells(ThisWorkbook.Names("UnitInfo").RefersToRange.Rows.Count, 1)
If Len(.Value) > 0 Then
.Offset(1, 0).Value = Target
Else
.Value = Target
End If
MsgBox (Target & " added to list.")
End With
End If
End If
Application.EnableEvents = True
End If
ActiveWorkbook.Sheets("MyM").Select
    ActiveWorkbook.Worksheets("MyM").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("MyM").Sort.SortFields.Add Key:=Range("L1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("MyM").Sort
        .SetRange Range("L1:L10000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
  
End With
Sheets("MyM").Protect Password:="help"
Sheets("17").Select
Range("C20").Select
OrderlyExit: Application.EnableEvents = True
End Sub

If anyone has any ideas on making this better and less flickering, I'd appreciate it.

Regards,
Leaning