Makro ile hücre kilitleyip açma

[afetidelala]

Öncelikle merhabalar üstadlarım aşağıdaki makro koduyla çalışma sayfamdan çıkış yaparken pc de belittiğim farklı bir yere yedekliyorum ve buna ek olarak bu dosya içerisinde seçeceğim birkaç sayfanın dolu olan tüm hücrelerinin de bu çıkış işlemi sırasında kilitlenmesini istiyorum kaydet ve çık butonuna bastığımda önce seçtiğim sayfalardaki dolu olan tüm hücreleri kilitleyecek sonra kaydedip yedekleme işlemini yapacak. bide aklıma takılan bişey var eğer bu dosyayı makro ile kilitlersem şifresi ne olacak onu kim belirleyecek gibi daha bi dünya soru var ama neyse nasipse bi başlayalım sonu gelir inşallah.örnek dosya eklemek isterdim ama ekleyemiyorum altın üyelik diye bişey çıkmış :S site yönetimi için ne kadar uygundur bilmiyorum ama bende bi upload sitesine dosymı yüklyerek link koymak istedim yardım edebilecek bi üstad arıyorum dosyanın koruma şifresi 112233 makroda bazı bölümlerde şifre istiyor oda
kullanıcı adı : 1111
şifre : 2222
bunları yazmamın sebebi daha önce bi üstadım dosyada şifre olduğu için ve şifreyi konuda belirtmediğim için yardım etmemişti

bide excel ve makrodan hiç anlamayan biri olarak yaptığım bu dosyaya siz üstatdlarımdan bi yorum bekliyorum lütfen...

dosya link i :

http://www.dosya.tc/server22/X5dEOm/oynama.xls.html

kaydetme ve yedekleme kodu :

Private Sub CommandButton2_Click()
Dim DosyaSistemi As Object, Aktif_Dosya_Adı As String
Dim Yedek_Dosya_Adı As String, Kayıt_Yeri As String

Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
Aktif_Dosya_Adı = ThisWorkbook.FullName
Yedek_Dosya_Adı = Replace(ThisWorkbook.Name, "", "")

Kayıt_Yeri = "G:\Programlar\PROGRAMLAR VE KURULUMLARI\SAYAÇ & BACA GAZI PROGRAMLARI\alp teknik)\e680\Kilitli\Yeni Klasör\111\Kilitli\yedeklemeler\" & Yedek_Dosya_Adı

ThisWorkbook.Save

On Error Resume Next
If Dir("G:\Programlar\PROGRAMLAR VE KURULUMLARI\SAYAÇ & BACA GAZI PROGRAMLARI\alp teknik)\e680\Kilitli\Yeni Klasör\111\Kilitli\yedeklemeler\") = "" Then MkDir ""
DosyaSistemi.CopyFile Aktif_Dosya_Adı, Kayıt_Yeri

MsgBox "Dosyanız aşağıdaki isimle yedeklenmiştir." & Chr(10) & Yedek_Dosya_Adı, vbInformation, "CELL_O"

cevap = MsgBox(" DOSYA KAPATILACAK DEĞİŞİKLİKLER KAYDEDİLSİN Mİ ? ", vbYesNoCancel, "CELL_O")
If cevap = vbCancel Then Exit Sub
If cevap = vbNo Then Application.Quit
If cevap = vbYes Then
ActiveWorkbook.Save
Application.Quit
End If
End Sub

 

[Muzaffer Ali]

ActiveWorkbook.Save

Satırından önce şu kodları yazın

    Selection.Locked = True 'Seçili hücreleri kilitler
    'adres belirtmek isterseniz
    Range("a1:b10").Locked = True 'Adresini belirttiğiniz hücreleri kilitler
    Sayfa1.Protect

 

[afetidelala]

ActiveWorkbook.Save

Satırından önce şu kodları yazın

    Selection.Locked = True 'Seçili hücreleri kilitler
    'adres belirtmek isterseniz
    Range("a1:b10").Locked = True 'Adresini belirttiğiniz hücreleri kilitler
    Sayfa1.Protect

ilginiz için teşekkürler hocam fakat burada sadece seçtiğimiz aralıktaki hücreleri kilitliyor tamam o şekildede olsun fakat şöle bi seçenek ekleye bilirmiyiz örnek veriyorum
sayfa1 de A1 ile A55 arasında ki dolu hücreleri kilitlesin bu mümkünmüdür :S

 

[Muzaffer Ali]

    Sayfa1.Range("a1:b10").Locked = True 'Adresini belirttiğiniz hücreleri kilitler
    Sayfa1.Protect

 

[afetidelala]

hocam bi işe yaramadı kilitlemiyor

hocam kilitlemiyor veya kilitliyorsa bile ben her açışımda hücrelere müdehale edip değiştirebiliyorum yani bi işe yaramıyor :S

 

[Muzaffer Ali]

Aşağıdaki şeklilde dener misiniz?

Private Sub CommandButton2_Click()
 Dim DosyaSistemi As Object, Aktif_Dosya_Adı As String
 Dim Yedek_Dosya_Adı As String, Kayıt_Yeri As String

 Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
 Aktif_Dosya_Adı = ThisWorkbook.FullName
 Yedek_Dosya_Adı = Replace(ThisWorkbook.Name, "", "")

 Kayıt_Yeri = "G:\Programlar\PROGRAMLAR VE KURULUMLARI\SAYAÇ & BACA GAZI PROGRAMLARI\alp teknik)\e680\Kilitli\Yeni Klasör\111\Kilitli\yedeklemeler\" & Yedek_Dosya_Adı

 ThisWorkbook.Save

 On Error Resume Next
 If Dir("G:\Programlar\PROGRAMLAR VE KURULUMLARI\SAYAÇ & BACA GAZI PROGRAMLARI\alp teknik)\e680\Kilitli\Yeni Klasör\111\Kilitli\yedeklemeler\") = "" Then MkDir ""
 DosyaSistemi.CopyFile Aktif_Dosya_Adı, Kayıt_Yeri

 MsgBox "Dosyanız aşağıdaki isimle yedeklenmiştir." & Chr(10) & Yedek_Dosya_Adı, vbInformation, "CELL_O"

    Sayfa1.Range("a1:b10").Locked = True 'Adresini belirttiğiniz hücreleri kilitler
    Sayfa1.Protect

 cevap = MsgBox(" DOSYA KAPATILACAK DEĞİŞİKLİKLER KAYDEDİLSİN Mİ ? ", vbYesNoCancel, "CELL_O")
 If cevap = vbCancel Then Exit Sub
 If cevap = vbNo Then Application.Quit
 If cevap = vbYes Then
 ActiveWorkbook.Save
 Application.Quit
 End If
 End Sub