% ile rastgele tekrarsız seçim

[_frost_]

İşlem tamamlanıp veriler ikinci hücreye kopyalandıktan sonra kilitlenmesini ve değişikliklere kapanmasını istiyorum. Bu nedenle şu kodu ekledim;

Dim hcr As Range
ActiveSheet.Unprotect
For Each hcr In Cells.CurrentRegion
If IsEmpty(hcr) Then
hcr.Locked = False
Else
hcr.Locked = True
End If
Next
ActiveSheet.Protect

ama hcr.Locked =True kısmında hata veriyor. Bunu nasıl düzeltebilirim ya da yazmam gerekn kod nedir acaba?
Şimdiden çok teşekkür ederim..

 

[leumruk]

Merhaba,
Kilitlenmesini istediğiniz nedir? Hücreler mi; yoksa sayfa mı?
Bu söylediğiniz işlemi hangi sayfada yapmak istiyorsunuz? Ana sayfada mı; verilerin aktarıldığı sayfada mı?
Daha ayrıntılı bir açıklama yapmanızı rica ediyorum.

 

[_frost_]

Aktarılan hücreleri aktarıldıkları sayfada değişikliklere karşı korumak istiyorum. Kopyalamaya izin vermek ama değişiklik yapılmasına izin vermemek istiyorum.. Tabi sizin değerli fikirlerinize de açığım.. Açıklamamın önceki mesajda yetersiz olmasından dolayı özür dilerim.

 

[leumruk]

Aktarılan hücreleri aktarıldıkları sayfada değişikliklere karşı korumak istiyorum. Kopyalamaya izin vermek ama değişiklik yapılmasına izin vermemek istiyorum.. Tabi sizin değerli fikirlerinize de açığım.. Açıklamamın önceki mesajda yetersiz olmasından dolayı özür dilerim.

Peki makro yeniden çalıştığında işlem yapsın mı? Yani sadece elle değişiklik yapılmasını mı engellemek istiyorsunuz?

 

[_frost_]

Evet dediğiniz gibi, makro çalıştığında veriler değişebilir ama elle müdaheleye izin vermiyeceğiz.

 

[leumruk]

Evet dediğiniz gibi, makro çalıştığında veriler değişebilir ama elle müdaheleye izin vermiyeceğiz.

Dosyanızdaki kodu aşağıdaki ile değiştirin.

Sub Yuzdeli()
Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False
s2.Unprotect
s2.Cells.Delete
Tpl = [b65536].End(3).Row - 3
Sor = Application.InputBox("Lütfen yüzde oranını girin.", "YÜZDELİK DİLİM")
If Sor = False Then Exit Sub
If Sor > 100 Then Exit Sub
If Not IsNumeric(Sor) Then Exit Sub
oran = Round(Tpl * Sor / 100, 0)
Application.ScreenUpdating = False
Do
Tekrar:
sayi = Int((Tpl * Rnd) + 1)
Knt = WorksheetFunction.CountIf(s2.Range("a1:a" & s2.[a65536].End(3).Row), sayi + 3)
If Knt > 0 Then GoTo Tekrar
s2.Cells(s2.[a65536].End(3).Row + 1, "a") = sayi + 3
SonSut = Cells(3, 256).End(1).Column
Range(Cells(sayi + 3, 2), Cells(sayi + 3, SonSut)).Copy s2.Cells(s2.[b65536].End(3).Row + 1, "b")
Say = Say + 1
Loop While oran <> Say
s2.Columns(1).Delete Shift:=xlToLeft
Application.CutCopyMode = False
s2.Cells.Locked = True
s2.Protect
MsgBox "İşlem tamamlanmıştır.", vbInformation, "l e u m r u k"
End Sub

 

[_frost_]

Sayın Leumruk, yardımlarınız için çok teşekkür ederim. Çalışmalarınızda başarılar dilerim.