bilgisayar adina gore sutun koruma

[desk]

merhaba sayfa koruma da parola girerek sutun koruma yapabiliyoruz bunu parolasız girmeden sayfayı açtığı gibi örnek bilgisayar adı ali ve veli olan bilgisayarların belirttiğim sutunlarda değiştirme yapabilmesini sağlayabilmem mümkünmü.? bu kullanıcılar haricinde hiçbir pc bu sutunu değiştirememeli.

 

[Ömer]

Merhaba,

Küçük bir örnek, bu örnek üzerinden ilerleyebilirsiniz.

Sub Auto_Open()

    Dim ad As String
        
    ad = Environ("UserName")
    
    Sheets("Sayfa1").Unprotect "123" 'korumayı kaldırır. şifre 123
    
    If ad = "omr" Then
        Cells.Locked = False
        Columns("E:E").Locked = True
    ElseIf ad = "brs" Then
        Cells.Locked = False
        Columns("H:H").Locked = True
    ElseIf ad = "asd" Then
        Cells.Locked = False
        Columns("C:C").Locked = True
    End If
    
    Sheets("Sayfa1").Protect "123" 'koruma koyar. şifre 123
  
End Sub

.

 

[desk]

Merhaba,

Küçük bir örnek, bu örnek üzerinden ilerleyebilirsiniz.

Sub Auto_Open()

    Dim ad As String
        
    ad = Environ("UserName")
    
    Sheets("Sayfa1").Unprotect "123" 'korumayı kaldırır. şifre 123
    
    If ad = "omr" Then
        Cells.Locked = False
        Columns("E:E").Locked = True
    ElseIf ad = "brs" Then
        Cells.Locked = False
        Columns("H:H").Locked = True
    ElseIf ad = "asd" Then
        Cells.Locked = False
        Columns("C:C").Locked = True
    End If
    
    Sheets("Sayfa1").Protect "123" 'koruma koyar. şifre 123
  
End Sub

.

üstad öncelikle ilgilendiğin için çok teşekkür ederim.
aşağıdaki gibi direk gizleme yapabiliyorum direk o sütunlara kilitleme yapamıyorum aslında böyle pratik bir şekilde işimi görecek. gizler gibi direk can ve recep dışına kilitleyemezmiyiz.

Private Sub Workbook_Open()
If Application.UserName = "CAN" Or Application.UserName = "RECEP" Then
Cells.Columns.Hidden = False
Else
Columns("C").Hidden = True
Columns("D").Hidden = True
End If
End Sub

 

[Ömer]

Benim verdiğim örnek kitleme yapıyor. Sayfa koruma mantığıyla.

 

[desk]

kilitleme yapıyor tüm sayfayı ben ali ve veli C ve D sutununu değiştirebilsin diğer kullanıcılar bu sutunları değiştiremesin ama diğer sutunlarda serbest olsun istiyorum.

 

[desk]

kilitleme özelliğini kullanmadan sutunları koruyamıyormuyuz.?

 

[Ömer]

Aklıma gelen başka bir yolu yok.
Ya gizlersiniz ya kilitleyip işlem yapmasını engellersiniz, yada sütundaki hücrelerin seçilmesini aşağıdaki bir yapı ile engellersiniz.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub
    
    Target.Offset(0, 1).Select
    
End Sub

.

 

[Korhan Ayhan]

Alternatif,

Tam çözüm olmasa da işinize yarayabilir.

Boş bir modüle;

Option Explicit
Public Kullanici As String

BuÇalışmaKitabı (ThisWorkBook) bölümüne;

Option Explicit

Private Sub Workbook_Open()
    Kullanici = Application.UserName
End Sub

Bu işlemi yapmak istediğiniz sayfanın kod bölümüne;

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Son
    If Intersect(Target, Range("C:D")) Is Nothing Then Exit Sub
    Select Case Kullanici
        Case "Ali", "Veli"
        Case Else
            Application.EnableEvents = False
            Application.Undo
            MsgBox "Bu işlem için yetkiniz bulunmamaktadır!", vbCritical
    End Select
Son: Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("C:D")) Is Nothing Then Exit Sub
    Select Case Kullanici
        Case "Ali", "Veli"
        Case Else
            MsgBox "Bu işlem için yetkiniz bulunmamaktadır!", vbCritical
    End Select
End Sub

 

[Necdet]

Merhaba,

Application.UserName işe yaramaz. Kullanıcı kendi bilgisayarında bunu istediği gibi değiştirebilir.

Belki Bilgisayar adı önemli olabilir.

Environ("ComputerName") di sanırım bilgisayarın adını alan kod.

 

[Korhan Ayhan]

Aşağıdakilerden birisi tercih edilebilir.

Sub Test()
    MsgBox Environ("UserName")
    MsgBox Environ("ComputerName")
    MsgBox Application.UserName
End Sub

 

[desk]

Alternatif,

Tam çözüm olmasa da işinize yarayabilir.

Boş bir modüle;

Option Explicit
Public Kullanici As String

BuÇalışmaKitabı (ThisWorkBook) bölümüne;

Option Explicit

Private Sub Workbook_Open()
    Kullanici = Application.UserName
End Sub

Bu işlemi yapmak istediğiniz sayfanın kod bölümüne;

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Son
    If Intersect(Target, Range("C:D")) Is Nothing Then Exit Sub
    Select Case Kullanici
        Case "Ali", "Veli"
        Case Else
            Application.EnableEvents = False
            Application.Undo
            MsgBox "Bu işlem için yetkiniz bulunmamaktadır!", vbCritical
    End Select
Son: Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("C:D")) Is Nothing Then Exit Sub
    Select Case Kullanici
        Case "Ali", "Veli"
        Case Else
            MsgBox "Bu işlem için yetkiniz bulunmamaktadır!", vbCritical
    End Select
End Sub

Öncelikle zaman ayırdığın için çok teşekkür ederim. Yine farkını ortaya koymuşsun üstad tam istediğim gibi oldu tam sonucu

Private Sub Workbook_Open()
    Kullanici = Environ("ComputerName")
End Sub

bilgisayar adıyla aldım konuma cevap veren herkeze sonsuz teşekkürler.
iyi çalışmalar.