Bırden fazla excel 'de, aynı adresli alanların "protected" hale getirecek bir makro

[serhatc]

Bırden fazla excel 'de, aynı adresli alanların "protected" hale getirecek bir makro

Merhaba,

Aşağıda detaylı olarak bahsettiğim konuda, bilgisi ve çözümü olabilecek olan arkadaşlardan destelerini rica ediyorum.

TANIMLAMA:

* C:\ üzerinde, aynı dizinde yer alan çok sayıda excel dosya var.

* Bu excel dosyaların içerisinde hep aynı isimli "Sheet" var.

* Bu "Sheet" üzerinde, sadece A1:B10 , C3 ve G4:K54 alanlarını "protected" hale getirilmesi gerekiyor. (Diğer tüm hücrelere giriş yapılabilecek)

* Bir üst madde de bahsedilen alanlar "protected" yapıldıktan sonra, "Protection" 'dan "Protect Sheet" 'e girilip "Password to unprotect sheet" kısmına "E1w2" şifresinin tanımlanması, "Allow all users of this worksheet to" listesinde ise sadece "Select unlocked cells", "Edit objects", "Edit scenarios" seçeneklerinin seçili, diğerlerinin seçili olmamasının sağlanması gerekiyor.

* Bu aşamadan sonra, o an çalışılan ve açık olan excel dosyanın, ilk açıldığı dizin üzerine yien aynı isimle "repalce" edilmesi gerekiyor.

YARDIM TALEBİ

Bu yukarıda işlemler, aynı dizinde saklı 1000 'den fazla excel için tekrarlanacak.
Tek tek tüm excellere girip manual yapmak yerine, otomatik yapılmasını sağlayacak bir makro yazılabilir mi?

İlginiz ve Desteğiniz için şimdiden teşekkürler.

Serhat

 

[Ömer]

Merhaba,

Module kopyalayıp çalıştırın. Yol = "C:\Deneme\" komutundaki adresi kendinize göre değiştirirsiniz.

Sub KorumaKoy()
    Dim Yol As String, Dosya As String
    
    Yol = "C:\Deneme\"
    Dosya = Dir(Yol & "*.xl*")
    
    Application.ScreenUpdating = False
    While Dosya <> ""
        Workbooks.Open Yol & Dosya
        ActiveSheet.Unprotect "E1w2"
        Cells.Locked = False
        Cells.FormulaHidden = False
        
        Range("A1:B10,C3,G4:K54").Locked = True
        Range("A1:B10,C3,G4:K54").FormulaHidden = True
        ActiveSheet.Protect Password:="E1w2", DrawingObjects:=False, Contents:=True, Scenarios:=False
        ActiveWorkbook.Save
        ActiveWorkbook.Close
        Dosya = Dir
    Wend
    MsgBox "İşlem Tamam", , "www.excel.web.tr"
    Application.ScreenUpdating = True
End Sub