Sayfa Koruması

[cember68]

Private Sub Worksheet_Change(ByVal Target As Range)
Sheets("1").Unprotect Password:="12345"
Dim S1 As Worksheet, c As Range
Dim S2 As Worksheet

Set S1 = Sheets("2")
Set S2 = Sheets("1")

On Error Resume Next

If Intersect(Target, [c:c]) Is Nothing Then Exit Sub

With Target
Set c = S1.[A:A].Find(.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
.Offset(0, 1) = S1.Range("B" & c.Row)
.Offset(0, 2) = S1.Range("C" & c.Row)
.Offset(0, 3) = S1.Range("D" & c.Row)
.Offset(0, 4) = S1.Range("E" & c.Row)
.Offset(0, 5) = S1.Range("G" & c.Row)
.Offset(0, 6) = S1.Range("H" & c.Row)
.Offset(0, 7) = S1.Range("I" & c.Row)
.Offset(0, 8) = S1.Range("J" & c.Row)

Else
Range("D" & .Row & ":F" & .Row).ClearContents
MsgBox "YİBF NO TALEP DOSYASINDA YOKTUR..."
End If
End With
Sheets("1").Protect Password:="12345"
End Sub



C sütunu değişkeninde çalışan bir kod var. B-C-L-M sütunlarında veri girebileceğim hücreler var kilitli değiller.Diğer sütunlarım kilitli.C sütununda herhangi bir değişiklikte sayfa koruması kalkmıyor.Fakat B sütununa veri girdiğimde sayfa korumasını kaldırıyor.Korumayı kaldırmasını nasıl engellerim?

 

[Muzaffer Ali]

Merhaba.

Şu satırı kes

Sheets("1").Unprotect Password:="12345"

Şu satırın altına yapıştır.

If Intersect(Target, [c:c]) Is Nothing Then Exit Sub

 

[cember68]

Merhaba.

Şu satırı kes

Sheets("1").Unprotect Password:="12345"

Şu satırın altına yapıştır.

If Intersect(Target, [c:c]) Is Nothing Then Exit Sub

Çok teşekkürler .Sağolun.