Listbox'tan hücreye veri aktarma

[gokhan83]

Merhaba
Listboxta ki isimleri seçerek ilgili hücrelere yazılmasını sağlayan bir kod var. Ancak kod çok uzun ve değişiklik yapmak istediğimde çok zaman alıyor. Ekte kodun bir kısmı var. Bu kodu nasıl kısalta bilirim?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If ActiveCell.Row = 28 And ActiveCell.Column = 2 Then
ActiveSheet.Unprotect Password:="1453"
ActiveCell.Value = ""
UserForm1.ListBox1.ControlSource = "B28"
UserForm1.Show
ActiveSheet.Protect Password:="1453"

ElseIf ActiveCell.Row = 29 And ActiveCell.Column = 2 Then
ActiveSheet.Unprotect Password:="1453"
ActiveCell.Value = ""
UserForm1.ListBox1.ControlSource = "B29"
UserForm1.Show
ActiveSheet.Protect Password:="1453"

ElseIf ActiveCell.Row = 30 And ActiveCell.Column = 2 Then
ActiveSheet.Unprotect Password:="1453"
ActiveCell.Value = ""
UserForm1.ListBox1.ControlSource = "B30"
UserForm1.Show
ActiveSheet.Protect Password:="1453"

ElseIf ActiveCell.Row = 31 And ActiveCell.Column = 2 Then
ActiveSheet.Unprotect Password:="1453"
ActiveCell.Value = ""
UserForm1.ListBox1.ControlSource = "B31"
UserForm1.Show
ActiveSheet.Protect Password:="1453"

ElseIf ActiveCell.Row = 32 And ActiveCell.Column = 2 Then
ActiveSheet.Unprotect Password:="1453"
ActiveCell.Value = ""
UserForm1.ListBox1.ControlSource = "B32"
UserForm1.Show
ActiveSheet.Protect Password:="1453"
End If
End Sub

 

[gokhan83]

Arkadaşlar bu kod hakkında yardımcı olabilecek biri var mı?

 

[gokhan83]

Konu hakkında yardımcı olabilecek var mı?