Track users who use excel file

[ShieBoon]

Hello, do you guys know of any code that can allow me to track the users who use a shared excel file and log the records in a worksheet within the file?

i'm using xl 2003

 

[Roj47]

What a neat piece of code!

How do I view the log though or am I using something incorrectly please?

 

[VoG]

You can run these from a standard module to show or hide the Log sheet

Sub ViewLog()
Sheets("Log").Visible = xlSheetVisible
End Sub


Sub HideLog()
Sheets("Log").Visible = xlSheetVeryHidden
End Sub

 

[Damo10]

Hi,

I think the issue I am having is that macros are not enabled when the workbook opens as it runs fine on a new workbook.

Is there any way to ensure that macros are enabled when the workbook opens?

Regards

 

[VoG]

You need to change the settings in macro security to the lowest (i.e allow all macros).

 

[Damo10]

Hi VoG,

Thanks for your help as I have now got it to work.

The only issue that I have found is that if the cell already contains some data and then that data is ammeded and not overwritten that the code puts the new data in both the previous content and new content columns. Is there anything that can be done with this?

Regards Damian

 

[VoG]

Try

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim LR As Long, NewVal As Variant, OldVal As Variant
If Sh.Name = "Log" Then Exit Sub
If Not Intersect(Target, Range("Data")) Is Nothing Then Exit Sub
Application.EnableEvents = False
NewVal = Target.Value
Application.Undo
OldVal = Target.Value
Target.Value = NewVal
If OldVal <> NewVal Then
    With Sheets("Log")
        LR = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A" & LR + 1).Value = VBA.Environ("username") 'user
        .Range("B" & LR + 1).Value = Now 'date and time
        .Range("C" & LR + 1).Value = Sh.Name 'sheet
        .Range("D" & LR + 1).Value = Target.Address(False, False) 'cell
        .Range("E" & LR + 1).Value = OldVal 'previous value
        .Range("F" & LR + 1).Value = Target.Value 'new value
    End With
End If
Application.EnableEvents = True
End Sub

 

[Damo10]

Hi,

Thank you so much for your help so far.

I think I have found the issue that I am having, when I enter data into a cell there is another worksheet change event macro that enters a number into another cell which is used for another formula. When the Application.Undo runs it then gets the value from the cell that has been updated for the formula not the original data and the code loops through 2 times due to there being 2 changes.

Any suggestions?

 

[VoG]

Can you post your other code.

 

[Damo10]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range, c1 As Range
Dim ma As Range
Dim nextcell As Range
Set nextcell = ActiveCell(1)
Set c1 = Target.Cells(, 14)
 
With Target
If .MergeCells And .WrapText Then
With ActiveSheet
.Protect Password:="pw", AllowFormattingCells:=True, userinterfaceonly:=True
.EnableSelection = xllockedCells
End With
Set c = Target.Cells(1, 1)
r1 = Target.Row
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
Application.ScreenUpdating = False
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight + 1
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
ma.Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 1
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
c1 = Target.Height
Row = ActiveCell.Row
Avalue = Range("AA" & Row).Value
If Target.Cells.Height < Avalue Then
Rows(r1).RowHeight = Avalue
End If
Selection.Locked = False
Selection.FormulaHidden = False
nextcell.Select
Else
nextcell.Select
End If
End With
End Sub

 

[VoG]

Perhaps

Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range, c1 As Range
Dim ma As Range
Dim nextcell As Range
Application.EnableEvents = False
Set nextcell = ActiveCell(1)
Set c1 = Target.Cells(, 14)
 
With Target
If .MergeCells And .WrapText Then
With ActiveSheet
.Protect Password:="pw", AllowFormattingCells:=True, userinterfaceonly:=True
.EnableSelection = xllockedCells
End With
Set c = Target.Cells(1, 1)
r1 = Target.Row
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
Application.ScreenUpdating = False
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight + 1
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
ma.Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 1
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
c1 = Target.Height
Row = ActiveCell.Row
Avalue = Range("AA" & Row).Value
If Target.Cells.Height < Avalue Then
Rows(r1).RowHeight = Avalue
End If
Selection.Locked = False
Selection.FormulaHidden = False
nextcell.Select
Else
nextcell.Select
End If
End With
Application.EnableEvents = True
End Sub