Lock and unlock lines in worksheet based on usrname

[xaxaredbul]

Hello

I have shared workbook in witch multiple users are creating new lines whit data.
I want to make VBA code that is allowing only to specific user to be able to change cells in the line of witch one of the cells is having his name.
Excel have similar function build in but its working only if you don't add new lines.

Thank You!

[大灰狼1976]

Hi xaxaredbul!
It's not difficult to achieve this. Please provide a sample form.

[xaxaredbul]

Yo can use this file.
The Pcname is in the Worksheet script.
Sample.xlsm

[大灰狼1976]

I don't quite understand, but you can try to do like below.

Private Sub Workbook_Open()
Dim UserName As String, d As Object, i&
Set d = CreateObject("scripting.dictionary")
d.Add "dlagm001", "Ivan"
d.Add "blago001", "Ivan"
d.Add "kolev003", "Nadya"
d.Add "aptul001", "Birhan"
d.Add "karag001", "Nikolay"
d.Add "ramis001", "Semra"
d.Add "gueor001", "Ianko"
UserName = LCase(Environ("UserName"))
If d.exists(UserName) Then
  MsgBox "Hello " & d(UserName) & " " & vbNewLine & "10.12.2018 change:" & vbNewLine & "!Paste! function is removed for colums:B,C,H,K,L,O,Q."
  Styles("Normal").Interior.Color = RGB(240, 255, 255)
  With Sheets("KOBU")
    .Unprotect "123"
    For i = 7 To .[h65536].End(3).Row
      If InStr(.Cells(i, 8), Left(UserName, 5)) Then
        .Cells(i, 1).Resize(, 11).Locked = False
      End If
    Next i
    .Protect "123"
  End With
Else
  Sheets("KOBU").Unprotect "123"
  Cells.Locked = True
  Sheets("KOBU").Protect "123"
End If
End Sub

[xaxaredbul]

Ok Thank you.

now it's almost working, but is not protecting the hole line. It is protecting only some of the cells from this line.
The original file have columns from A to AH. Column H is the one that you have to take the name.

This is the updated version of the script that i made working partially.

Private Sub Workbook_Open()
Dim UserName As String, d As Object, i&
Set d = CreateObject("scripting.dictionary")
d.Add "dlagm001", "I.Dlagmanov"
d.Add "blago001", "I.Blagov"
d.Add "kolev003", "N.Koleva"
d.Add "aptul001", "B.Aptulov"
d.Add "karag001", "N.Karagyozov"
d.Add "ramis001", "S.Ramisova"
d.Add "gueor001", "I.Gueorguiev"
UserName = LCase(Environ("UserName"))
If d.exists(UserName) Then
  MsgBox "Hello " & d(UserName) & " " & vbNewLine & "10.12.2018 change:" & vbNewLine & "!Paste! function is removed for colums:B,C,H,K,L,O,Q."
  Styles("Normal").Interior.Color = RGB(240, 255, 255)
  With Sheets("List2")
    .Unprotect "123"
    For i = 7 To .[h65536].End(3).Row
      If InStr(.Cells(i, 8), Left(UserName, 5)) Then
        .Cells(i, 1).Resize(, 11).Locked = False
      End If
    Next i
    .Protect "123"
  End With
Else
  Sheets("List2").Unprotect "123"
  Cells.Locked = True
  Sheets("List2").Protect "123"
End If
End Sub

[大灰狼1976]

Please Mark the thread as [Solved] when you have an answer, thank you!

[xaxaredbul]

Yes but i still have not solved it. I cant make it to lock the hole line.