• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Protected Sayfada Çalışmayan Kod

Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
C

cevatyildiz

Katılım
2 Mayıs 2008
Mesajlar
295
Excel Vers. ve Dili
Office 365
Merhaba,

Paylaştırılmış ve korumalı sayfaları olan excel dosyasında aşağıdaki kodları çalıştırmak istiyorum. Ama aşağıdaki kodlar korumalı sayfalarda çalışmıyor. Yardımcı olabilir misiniz?

Not: Korumalı sayfaların şifresi :"1" dir.

Private Sub Workbook_Open()
On Error Resume Next
For Each sht In Worksheets
If sht.AutoFilterMode Then sht.ShowAllData
sht.Activate
ActiveWindow.FreezePanes = False
[i3].Select
ActiveWindow.FreezePanes = True
Next
End Sub
 

Ekli dosyalar

Selamlar,

Korumalı sayfalarda makrolar normalde çalışmaz. Bu sebeple ilk önce ilgili sayfanın korumasını kod ile kaldırıp işlemlerini yaptıktan sonra tekrar ilgili sayfayı korumaya almanız gerekiyor.

Kod: 
Private Sub Workbook_Open()
    On Error Resume Next
    For Each SHT In Worksheets
        [COLOR=red]SHT.Unprotect Password:=1[/COLOR]
        If SHT.AutoFilterMode Then SHT.ShowAllData
        SHT.Activate
        ActiveWindow.FreezePanes = False
        [i3].Select
        ActiveWindow.FreezePanes = True
        [COLOR=red]SHT.Protect Password:=1[/COLOR]
    Next
End Sub
 
Korhan Bey yardımınız için çok teşekkür ederim. Ayrıca şifre ile alakalı bir sorun yaşadıgımı da anlamış oldum. Sıfır ile başlayan şifreleri tırnak içinde belirtmedikçe kabul etmiyor ve kodu yazarken kendiliğinden siliyormuş.

iyi çalışmalar
 
Korhan Bey bir sorunum oluştu. Aynı sayfada aynı zamanda aşağıdaki kod ile satır renklendirme yapıyordum fakat su anda "Application defined or object defined error" hatası veriyor

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Son As Long
Dim cmt, Kontrol, sPath, sFile
    
Call ResetComments
Columns("D").ClearComments

Son = [b1000].End(4).Row

If Intersect(Target, Range("A3:H" & Son)) Is Nothing Then Exit Sub

If Target.Count > 1 Then Exit Sub

Application.ScreenUpdating = False
Range("A3:J" & Son).Interior.ColorIndex = xlNone
Range("A3:J" & Son).Font.Bold = False
Range("L3:L" & Son).Interior.ColorIndex = xlNone
Range("L3:L" & Son).Font.Bold = False
Range("N3:R" & Son).Interior.ColorIndex = xlNone
Range("N3:R" & Son).Font.Bold = False
Range("T3:W" & Son).Interior.ColorIndex = xlNone
Range("T3:W" & Son).Font.Bold = False
Range("Y3:AA" & Son).Interior.ColorIndex = xlNone
Range("Y3:AA" & Son).Font.Bold = False
Range("AC3:AE" & Son).Interior.ColorIndex = xlNone
Range("AC3:AE" & Son).Font.Bold = False

Range("A" & Target.Row & ":J" & Target.Row).Interior.ColorIndex = 36
Range("A" & Target.Row & ":J" & Target.Row).Font.Bold = True
Range("L" & Target.Row & ":L" & Target.Row).Interior.ColorIndex = 36
Range("L" & Target.Row & ":L" & Target.Row).Font.Bold = True
Range("N" & Target.Row & ":R" & Target.Row).Interior.ColorIndex = 36
Range("N" & Target.Row & ":R" & Target.Row).Font.Bold = True
Range("T" & Target.Row & ":W" & Target.Row).Interior.ColorIndex = 36
Range("T" & Target.Row & ":W" & Target.Row).Font.Bold = True
Range("Y" & Target.Row & ":AA" & Target.Row).Interior.ColorIndex = 36
Range("Y" & Target.Row & ":AA" & Target.Row).Font.Bold = True
Range("AC" & Target.Row & ":AE" & Target.Row).Interior.ColorIndex = 36
Range("AC" & Target.Row & ":AE" & Target.Row).Font.Bold = True
 
Selamlar,

Sn. cevatyildiz,

Aynı sorun sayfadaki renklendirme kodunuz içinde geçerlidir. Sayfa koruması varsa hiçbir kod çalışmaz. Bunun için sayfa korumasını kaldıran kod bloğunu her makronuzun başına eklemeniz gerekiyor.

Dim ile başlayan satırlarınızdan sonra aşağıdaki satırı yazın.

Kod: 
ActiveSheet.Unprotect Password:=1


Son olarakta kodlarınızın en son satırı olan End Sub satırından öncesinede aşağıdaki kodu yazın.

Kod: 
ActiveSheet.Protect Password:=1
 
Korhan Bey sayfayı açıyor fakat tekrardan kilitlemiyor. Kilitlendiğinde aşağıdaki özelliklerle beraber kilitlenmesini sağlayabilir miyiz?

Format Cells
Select Locked Cells
Select Unlocked Cells
Format Cells
Format Rows
Use Autofilter
Edit Objects
 

Ekli dosyalar

Selamlar,

Kilitleme işlemini yapan kod bloğunu yanlış yere yazmışsınız.

Kod: 
[COLOR=blue]ActiveSheet.Protect Password:=1
[/COLOR][COLOR=red]End If[/COLOR]

Mavi renkli satır kırmızı renkli satırın altında olmalıdır.

Kilitlemeden sonra bazı özellikleri kullanacaksınız sanırım. Bunun için End If satırından sonraki kilitleme kodunu aşağıdaki gibi değiştirin.

Kod: 
[COLOR=red]End If[/COLOR]
ActiveSheet.Protect Password:=1, DrawingObjects:=False, Contents:=True, Scenarios:= _
True, AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFiltering:=True
 
Çok teşekkür ederim Korhan Bey yardımlarınız için...
Bu ekle alakalı son bir soru sorabilir miyim?

Ek te resim görüntüleme işlemini cmt de gerçekleştiriyorum ama bunun için kodlarda 300 x 300 pixellik alan içerisinde resimler bazen iki taraftan çekilmiş gibi görünüyor. Ben ise resimleri zoom özelliği ile orjinali gibi görmek istiyorum. Bu konuda yardımcı olabilir misiniz?

With cmt.Shape
.Fill.UserPicture sPath
.Width = 300
.Height = 300
 
Selamlar,

Aşağıdaki kodu denermisiniz. Yaptığım eklemeleri kırmızı renkle belirttim.

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Son As Long
    Dim cmt, Kontrol, sPath, sFile[COLOR=red], RWidth, RHeight[/COLOR]
    ActiveSheet.Unprotect Password:=1
 
    Call ResizeCommentsInSelection
    Call ResetComments
    Columns("D").ClearComments
 
    Son = [b1000].End(4).Row
 
    If Intersect(Target, Range("A3:H" & Son)) Is Nothing Then Exit Sub
 
    If Target.Count > 1 Then Exit Sub
 
    Application.ScreenUpdating = False
    Range("A3:J" & Son).Interior.ColorIndex = xlNone
    Range("A3:J" & Son).Font.Bold = False
    Range("L3:L" & Son).Interior.ColorIndex = xlNone
    Range("L3:L" & Son).Font.Bold = False
    Range("N3:R" & Son).Interior.ColorIndex = xlNone
    Range("N3:R" & Son).Font.Bold = False
    Range("T3:W" & Son).Interior.ColorIndex = xlNone
    Range("T3:W" & Son).Font.Bold = False
    Range("Y3:AA" & Son).Interior.ColorIndex = xlNone
    Range("Y3:AA" & Son).Font.Bold = False
    Range("AC3:AE" & Son).Interior.ColorIndex = xlNone
    Range("AC3:AE" & Son).Font.Bold = False
 
    Range("A" & Target.Row & ":J" & Target.Row).Interior.ColorIndex = 36
    Range("A" & Target.Row & ":J" & Target.Row).Font.Bold = True
    Range("L" & Target.Row & ":L" & Target.Row).Interior.ColorIndex = 36
    Range("L" & Target.Row & ":L" & Target.Row).Font.Bold = True
    Range("N" & Target.Row & ":R" & Target.Row).Interior.ColorIndex = 36
    Range("N" & Target.Row & ":R" & Target.Row).Font.Bold = True
    Range("T" & Target.Row & ":W" & Target.Row).Interior.ColorIndex = 36
    Range("T" & Target.Row & ":W" & Target.Row).Font.Bold = True
    Range("Y" & Target.Row & ":AA" & Target.Row).Interior.ColorIndex = 36
    Range("Y" & Target.Row & ":AA" & Target.Row).Font.Bold = True
    Range("AC" & Target.Row & ":AE" & Target.Row).Interior.ColorIndex = 36
    Range("AC" & Target.Row & ":AE" & Target.Row).Font.Bold = True
    'Application.ScreenUpdating = True
 
    '**************************************************************************************
    On Error Resume Next
 
    If Target.Column = 4 Then
 
        sFile = Cells(Target.Row, "D") & ".gif"
        sPath = ThisWorkbook.Path & "\Pictures\" & sFile
 
        Kontrol = Dir(sPath): If Kontrol = "" Then Exit Sub
 
[COLOR=red]       ActiveSheet.Pictures.Insert(sPath).Select[/COLOR]
[COLOR=red]       With Selection[/COLOR]
[COLOR=red]           RHeight = .Height[/COLOR]
[COLOR=red]           RWidth = .Width[/COLOR]
[COLOR=red]          .Delete[/COLOR]
[COLOR=red]       End With[/COLOR]
    
        Set cmt = Cells(Target.Row, "D").AddComment
        cmt.Visible = True
        cmt.Text Text:=sFile
 
        With cmt.Shape
            .Fill.UserPicture sPath
            .Width = [COLOR=red]RWidth[/COLOR]
            .Height = [COLOR=red]RHeight[/COLOR]
        End With
 
        Set cmt = Nothing
    End If
    ActiveSheet.Protect Password:=1, DrawingObjects:=False, Contents:=True, Scenarios:= _
    True, AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowFiltering:=True
End Sub
 
Süper oldu Korhan Bey ellerinize sağlık...

Bu arada bu dosyayı paylaşıma açıp herhangi bir hücreye tıkladıgımda

Unprotect method of Worksheet class failed hatası alıyorum..

Sayfa koruması ile ilgili bu hataya bir çözüm bulunabilir mi?
 

Ekli dosyalar

Selamlar,

Paylaştırılmış dosya konusunda daha önce forumda bir başlık açılmış. Sorunuzun yanıtı bu başlıkta bulunuyor. İncelermisiniz.

AĞDA PAYLAŞIM
 
Anladım Fillerin kanadı yoktur:)

Tesekkurler Korhan Bey
 
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
Geri
Üst