makrolu sayfaların koruma altına alınması

[kemal turan]

Merhaba uzman kardeşlerim,
Sizlerin yardımları ile yapmış olduğum excel tabanlı proğramım sektörde kullanılan ön muhasebe proğramlarına nazire edercesine yüksek performanslı olarak çalışmakta.
Yalnız bir sıkıntım var.
Eğer sayfanın kod penceresinde makro var ise, sayfayı koruma altına alamıyorum.Buda hücrelerde bulunan formülleri ve işlevleri koruyamama neden olmakta.
Bu hususta bir şey yapılabilir mi ?
Teşekkür ederim.

 

[hamitcan]

Activesheet.unprotect
...kodlarınız
Activesheet.protect

şeklinde kodlarınızı iki satır arasında yazarsanız, sayfa koruması açılır kodlarınız çalışır ve sayfa koruması tekrar devreye girer.

 

[Ömer]

Merhaba,

Linki inceleyiniz.

kod çalıştırmada sayfa koruma sorunu

.

 

[kemal turan]

Ömer bey merhaba,
sayfa kod penceresinde bulunan kodumuz aşağıdaki gibidir.
Vermiş olduğunuz kodu aşağıdaki gibi uyguladım.
Formül olan hücreleri kilitledim.
Sayfayı koruma altına aldım.
Fakat korumanın devre dışı kaldığını gördüm.
Nerede hata yapıyoruz ?
Yardımlarınızı beklyorum.
Teşekkürler
Activesheet.unprotect
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
c = 0
If Not Intersect(Target, [a24:a10000]) Is Nothing Then
[b24:E65536].ClearContents
If Target = "" Then Exit Sub
For a = 2 To [STOK!a65536].End(3).Row
If Sheets("stok").Cells(a, "a") = Target Then
c = c + 1
If WorksheetFunction.CountIf([b:b], Sheets("stok").Cells(a, "b")) = 0 Then
Cells(c + 23, "b") = Sheets("stok").Cells(a, "b")
Range("E24").Select
End If
End If
Next
[b24:b65536].Sort Key1:=[b24], Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End If


If Not Intersect(Target, [b24:b10000]) Is Nothing Then
[c24:E65536].ClearContents
If Target = "" Then Exit Sub
For a = 2 To [STOK!a65536].End(3).Row
If Sheets("STOK").Cells(a, "b") = Target Then
c = c + 1
If WorksheetFunction.CountIf([c:c], Sheets("STOK").Cells(a, "c")) = 0 Then
Cells(c + 23, "c") = Sheets("STOK").Cells(a, "c")
Range("E23").Select
End If
End If
Next
[c24:c65536].Sort Key1:=[c24], Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End If

If Not Intersect(Target, [c24:c10000]) Is Nothing Then
[d24:e65536].ClearContents
If Target = "" Then Exit Sub
For a = 2 To [STOK!a65536].End(3).Row
If Sheets("STOK").Cells(a, "c") = Target Then
c = c + 1
If WorksheetFunction.CountIf([d:d], Sheets("STOK").Cells(a, "d")) = 0 Then
Cells(c + 23, "d") = Sheets("STOK").Cells(a, "d")
Range("E24").Select
End If
End If
Next
[d24:d65536].Sort Key1:=[d24], Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End If


If Not Intersect(Target, [d24:d10000]) Is Nothing Then
[e24:e65536].ClearContents
If Target = "" Then Exit Sub
For a = 2 To [STOK!a65536].End(3).Row
If Sheets("STOK").Cells(a, "d") = Target Then
c = c + 1
If WorksheetFunction.CountIf([e:e], Sheets("STOK").Cells(a, "e")) = 0 Then
Cells(c + 23, "e") = Sheets("STOK").Cells(a, "e")
Range("E24").Select
End If
End If
Next
[e24:e65536].Sort Key1:=[E24], Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End If
If Intersect(Target, Range("D221")) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Target <> "" Then
Range("AR2:AU10000").ClearContents
Satır = 2
Set BUL = Sheets("SATIŞLAR").Range("A:A").Find(Target)
If Not BUL Is Nothing Then
Range("AX1") = BUL.Value
ADRES = BUL.Address
Do
If UCase(BUL.Offset(0, 10)) <> "SEVK OLDU" Then
Cells(Satır, "AR") = BUL.Offset(0, 16)
Cells(Satır, "AS") = BUL.Offset(0, 10)
Cells(Satır, "AT") = BUL.Offset(0, 1)
Cells(Satır, "AU") = BUL.Offset(0, 9)
Satır = Satır + 1
End If
Set BUL = Sheets("SATIŞLAR").Range("A:A").FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> ADRES
End If
End If
Set BUL = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Range("D1").Select

End Sub


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("E24:E10000")) Is Nothing Then Exit Sub
Selection.Copy
Range("E1").PasteSpecial Paste:=xlPasteValues
Satır = Range("E23").End(3).Row + 1
Cells(Satır, "E") = Satır - 1
Cells(Satır, "E") = [E1]
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
Range("E1").Select

End Sub
Activesheet.unprotect

 

[Ömer]

Başlık satırından sonra, bitiş satırından önce uygulamanız gerekir.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Activesheet.unprotect
kodlar
Activesheet.protect
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Activesheet.unprotect
kodlar
Activesheet.protect
End Sub


.

 

[kemal turan]

Ömer bey çok teşekkür ederim.
Aşağıdaki yerlere verdiğiniz kodu (kırmızı renkli) eklemeleri yapınca sorun çözüldü.
Çok teşekkür ederim.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Count > 1 Then Exit Sub
c = 0
If Not Intersect(Target, [a24:a10000]) Is Nothing Then
[b24:E65536].ClearContents
If Target = "" Then Exit Sub
For a = 2 To [STOK!a65536].End(3).Row
If Sheets("stok").Cells(a, "a") = Target Then
c = c + 1
If WorksheetFunction.CountIf([b:b], Sheets("stok").Cells(a, "b")) = 0 Then
Cells(c + 23, "b") = Sheets("stok").Cells(a, "b")
Range("E24").Select
End If
End If
Next
ActiveSheet.Unprotect
[b24:b65536].Sort Key1:=[b24], Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ActiveSheet.Protect
End If


If Not Intersect(Target, [b24:b10000]) Is Nothing Then
[c24:E65536].ClearContents
If Target = "" Then Exit Sub
For a = 2 To [STOK!a65536].End(3).Row
If Sheets("STOK").Cells(a, "b") = Target Then
c = c + 1
If WorksheetFunction.CountIf([c:c], Sheets("STOK").Cells(a, "c")) = 0 Then
Cells(c + 23, "c") = Sheets("STOK").Cells(a, "c")
Range("E23").Select
End If
End If
Next
ActiveSheet.Unprotect
[c24:c65536].Sort Key1:=[c24], Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ActiveSheet.Protect
End If

If Not Intersect(Target, [c24:c10000]) Is Nothing Then
[d24:e65536].ClearContents
If Target = "" Then Exit Sub
For a = 2 To [STOK!a65536].End(3).Row
If Sheets("STOK").Cells(a, "c") = Target Then
c = c + 1
If WorksheetFunction.CountIf([d:d], Sheets("STOK").Cells(a, "d")) = 0 Then
Cells(c + 23, "d") = Sheets("STOK").Cells(a, "d")
Range("E24").Select
End If
End If
Next
ActiveSheet.Unprotect
[d24:d65536].Sort Key1:=[d24], Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ActiveSheet.Protect
End If


If Not Intersect(Target, [d24:d10000]) Is Nothing Then
[e24:e65536].ClearContents
If Target = "" Then Exit Sub
For a = 2 To [STOK!a65536].End(3).Row
If Sheets("STOK").Cells(a, "d") = Target Then
c = c + 1
If WorksheetFunction.CountIf([e:e], Sheets("STOK").Cells(a, "e")) = 0 Then
Cells(c + 23, "e") = Sheets("STOK").Cells(a, "e")
Range("E24").Select
End If
End If
Next
ActiveSheet.Unprotect
[e24:e65536].Sort Key1:=[E24], Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ActiveSheet.Protect
End If
If Intersect(Target, Range("D221")) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Target <> "" Then
Range("AR2:AU10000").ClearContents
Satır = 2
Set BUL = Sheets("SATIŞLAR").Range("A:A").Find(Target)
If Not BUL Is Nothing Then
Range("AX1") = BUL.Value
ADRES = BUL.Address
Do
If UCase(BUL.Offset(0, 10)) <> "SEVK OLDU" Then
Cells(Satır, "AR") = BUL.Offset(0, 16)
Cells(Satır, "AS") = BUL.Offset(0, 10)
Cells(Satır, "AT") = BUL.Offset(0, 1)
Cells(Satır, "AU") = BUL.Offset(0, 9)
Satır = Satır + 1
End If
Set BUL = Sheets("SATIŞLAR").Range("A:A").FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> ADRES
End If
End If
Set BUL = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Range("D1").Select

End Sub


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Intersect(Target, Range("E24:E10000")) Is Nothing Then Exit Sub
Selection.Copy
Range("E1").PasteSpecial Paste:=xlPasteValues
Satır = Range("E23").End(3).Row + 1
Cells(Satır, "E") = Satır - 1
Cells(Satır, "E") = [E1]
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
Range("E1").Select

End Sub