Automatic comment on cell and Locked.

[bhushanmorwal1311]

Hi,


Can anybody help me on this?


I've Shared workbook and i want if somebody change the particular cell ( cell has time value), put the comment on the cell and lock for editing automatically ("comment" should be user-name).


I need this in VBA coding...


Thanks for help in advance.....

 

[SirJB7]

Hi, Bhushan!


Place this code in the VBA related worksheet.

-----

[pre]

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
' constants
' declarations
Dim I As Long, J As Long
' start
I = 0
J = 0
' process
With Target
For I = 1 To .Rows.Count
For J = 1 To .Columns.Count
With .Cells(I, J)
On Error Resume Next
.AddComment
If Err.Number = 0 Then
With .Comment
.Visible = False
.Text Text:=Application.UserName
End With
Else
Err.Clear
End If
End With
Next J
Next I
End With
' end
End Sub

[/pre]
-----


Regards!

 

[bhushanmorwal1311]

Hi SirJB7,


I appreciate your help,


but there's something more which i need like.


1) I want Particular cell not whole sheet. (like "A1" & "C1")


2) then comment on cell


3) then finally cell locked for editing...


and this is shared workbook.....!!!


Thanks so much.....!

 

[SirJB7]

Hi, Bhushan!


Try this:

-----

[pre]

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
' constants
Const ksRange1 = "A1"
Const ksRange2 = "C1"
' declarations
Dim rng As Range, I As Long, J As Long
' start
'  check
With Application
Set rng = .Intersect(.Union(Range(ksRange1), Range(ksRange2)), Target)
End With
If rng Is Nothing Then GoTo Worksheet_Change_Exit
'  initialize
I = 0
J = 0
ActiveSheet.Unprotect
' process
With rng
For I = 1 To .Rows.Count
For J = 1 To .Columns.Count
With .Cells(I, J)
On Error Resume Next
.AddComment
If Err.Number = 0 Then
With .Comment
.Visible = False
.Text Text:=Application.UserName
End With
.Locked = True
Else
Err.Clear
End If
End With
Next J
Next I
End With
' end
Worksheet_Change_Exit:
'  terminate
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Set rng = Nothing
End Sub

[/pre]
-----


Next time please try to formulate all requirements when starting topic. It's less time consuming and more efficient for people who might be able to help you.


Regards!


PS: I can't test shared behaviour, that's your homework.

 

[bhushanmorwal1311]

Thank you so much....... & I'll for next time..!


and its not working on the Shared workbook. thanks anyway...!


have a good day..

 

[SirJB7]

Hi, Bhushan!

Thanks for your feedback and for your kind words too. And welcome back whenever needed or wanted.

I suspected that on shared workbook

Regards!