makroya sayfa korumasını kaldırma ve ekleme kodu

[gedavet]

selam iyi çalışmalar bu kod alış sayfasından alınan sayfasına veri aktararak teke indiriyor "ALINAN" sayfasına örnek 123 diye koruma koymak istiyorum bu korumayı kaldırıp sonra çalışsa ve tekrar korumayı koysa kod aşağıda

Sub ÜRÜNLER()
'
If MsgBox(" E M İ N M İ S İ N İ Z", vbYesNo) = vbNo Then Exit Sub
'
Dim hcr As Range, sat As Long
Sheets("ALIŞ").Select
sat = 5
Application.ScreenUpdating = False
Sheets("ALINAN").Range("C5:C65536").ClearContents
For Each hcr In Range("E5:E" & Cells(65536, "E").End(xlUp).Row)
If WorksheetFunction.CountIf(Range("E5:E" & hcr.Row), hcr.Value) = 1 Then
Sheets("ALINAN").Cells(sat, "C").Value = hcr.Value
sat = sat + 1
End If
Sheets("ALINAN").Select
Range("C5:C104").Select
Selection.Sort Key1:=Range("C5"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("C5").Select
Sheets("ALIŞ").Select
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamam"
End Sub

şifreyi kaldırsın çalışsın ve tekrar şifreyi koysun şifrede 123 olabilir

 

[N.Ziya Hiçdurmaz]

yanıt

Sub ÜRÜNLER()
'
If MsgBox(" E M İ N M İ S İ N İ Z", vbYesNo) = vbNo Then Exit Sub
'
Dim hcr As Range, sat As Long
Sheets("ALIŞ").Select
sat = 5
Application.ScreenUpdating = False
Sheets("ALINAN").Unprotect
Sheets("ALINAN").Range("C5:C65536").ClearContents
For Each hcr In Range("E5:E" & Cells(65536, "E").End(xlUp).Row)
If WorksheetFunction.CountIf(Range("E5:E" & hcr.Row), hcr.Value) = 1 Then
Sheets("ALINAN").Cells(sat, "C").Value = hcr.Value
sat = sat + 1
End If
Sheets("ALINAN").Select
Range("C5:C104").Select
Selection.Sort Key1:=Range("C5"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("C5").Select
Sheets("ALINAN").Protect
Sheets("ALIŞ").Select
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamam"
End Sub

 

[gedavet]

ziya bey teşekkür ederim ancak sayfa koruması olarak şifre ne koyacağın şifrelemem lazım

 

[N.Ziya Hiçdurmaz]

yanıt

Sheets("ALINAN").Unprotect "123" 'koruma kaldır

Sheets("ALINAN").Protect "123" 'koruma koy

 

[gedavet]

Selection.Sort Key1:=Range("C5"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal


kodun bu kısmı sarı yanıyor hata veriyor