Create validation list with Worksheet_change

[LuisE]

I have this code to place a validation list in cell A9 every time any cell
from A41 and down below changes. Then under if a value es selected i'll
change B9

Am I missing anythin? doesn't work

Private Sub Worksheet_Change(ByVal Target As Range)
''''''''''Creates validation list with month's dates
Dim r As Range, txt As String

If Target.Row > 40 And Target.Column = 1 Then
Application.EnableEvents = False
Application.ScreenUpdating = False
ActiveSheet.Unprotect

For Each r In Range("A41", Range("A" & Rows.Count).End(xlUp))
If Not IsEmpty(r) Then txt = txt & "," & r.Value
Next
With Range("A9")
.Value = Empty
With .Validation
.Delete
.Add Type:=xlValidateList, Formula1:=Mid$(txt, 2)
End With
.Select
End With

Range("B9").Value = ""


Application.EnableEvents = True
Application.ScreenUpdating = True
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True,
AllowFiltering:=True


End If

If Target = Range("A9") Then
Range("B9") = WorksheetFunction.Text(ActiveSheet.Range("A9").Value, "DDD")
' DoIt
End If
End Sub


Thanks in advance

 

[Per Jessen]

Hi

Unprotect sheet ect. at the top off the sub and protect ect. just
before end sub. I assume that column A is unlocked when the sheet is
protected...

Private Sub Worksheet_Change(ByVal Target As Range)
''''''''''Creates validation list with month's dates
Dim r As Range, txt As String

Application.EnableEvents = False
Application.ScreenUpdating = False
ActiveSheet.Unprotect

If Target.Row > 40 And Target.Column = 1 Then
For Each r In Range("A41", Range("A" & Rows.Count).End(xlUp))
If Not IsEmpty(r) Then txt = txt & "," & r.Value
Next
With Range("A9")
.Value = Empty
With .Validation
.Delete
.Add Type:=xlValidateList, Formula1:=Mid$(txt, 2)
End With
.Select
End With
Range("B9").Value = ""
End If

If Target = Range("A9") Then
Range("B9") = WorksheetFunction.Text(ActiveSheet.Range
("A9").Value, "DDD")
' DoIt
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True, AllowFiltering:=True
End Sub

Regerds,
Per