Log sheet to track changes in VBA

[deadlyliquidx]

Hi there,

I have found variations about my problem but not my exact issue.
I need a log sheet that will log changes made on a tab called "Final" and log those changes in a tab called "log"
I would want who the person making the change was, the date it was made, the value it was before the change and the value it is now.

Now here is my problem, I want it to make sure it only tracks changes in column Z.
Only changes made in that column should be recorded.
Also what happens if someone were to copy and paste info into multiple rows in column Z.

 

[L. Howard]

This has been around for some time, but may be one of the variations you mention.

Also, it does more than you request, but you may be able to trim down the stuff you don't want it to do

Goes in the ThisWorkbook module.

Howard

Option Explicit

Private Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Const ERROR_MORE_DATA = 234
Const ERROR_INSUFFICIENT_BUFFER = 122

Public CurrentSheet As Worksheet, LogSheet As Worksheet
Private oldContents As Variant, autosave As Boolean

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    If Not autosave Then
        If LogSheet Is Nothing Then Exit Sub
        Dim r As Long
        r = LogSheet.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
        LogSheet.Cells(r, 1).Value = Now
        LogSheet.Cells(r, 2).Value = "Saved"
        LogSheet.Cells.Columns.AutoFit
    End If
End Sub

Private Sub Workbook_Open()
    'First, let's get the username -- network username if possible,
    'local username otherwise:
    Dim username As String, namelen As Long
    namelen = 2
    Do
        username = String$(namelen, vbNull)
        Select Case WNetGetUser("", username, namelen)
            Case 0                  'success
                username = Left$(username, namelen - 1)
                Exit Do
            Case ERROR_MORE_DATA    'username needs to be longer
                'Nothing to do: dll error sets namelen to length needed,
                'and username gets reset on next interation.
            Case Else               'other error; assume unable to retreive network name
                Do
                    username = String$(namelen, vbNull)
                    Select Case GetUserName(username, namelen)
                        Case 0      'failure
                            If Err.LastDllError = ERROR_INSUFFICIENT_BUFFER Then
                                'username needs to be longer, as with
                                'case ERROR_MORE_DATA above
                            Else    'other (unknown) error
                                username = "[error retreiving username]"
                                Exit Do
                            End If
                        Case Else   'success
                            username = Left$(username, namelen - 1)
                            Exit Do
                    End Select
                Loop
                Exit Do
        End Select
    Loop
    
    
    'Time to create the new log sheet:
    '/ If a log sheet exists then leave Exit Sub as is
    '/ Else remove to creat a log sheet then Exit Sub
    '/***********************************************
    
   ' Exit Sub
    
    '/***********************************************
    
    Dim wkBack As Worksheet
    Set wkBack = ActiveCell.Parent
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    Set LogSheet = Worksheets(Worksheets.Count)
    LogSheet.Visible = xlSheetHidden
    LogSheet.Name = "Log (" & Replace$(Date$, "/", "-") & " " & Replace$(Time$, ":", ".") & ")"
    LogSheet.Cells(1, 1).EntireRow.Font.Bold = True
    LogSheet.Cells(1, 1).Value = "Time"
    LogSheet.Cells(1, 2).Value = "Item"
    LogSheet.Cells(2, 1).Value = Now
    LogSheet.Cells(2, 2).Value = "File opened by " & username
    LogSheet.Cells.Columns.AutoFit
    wkBack.Activate
    Set wkBack = Nothing
    oldContents = Selection.Value
    autosave = True
    'Delete the next line if you don't want the "autosave on open" thing to happen.
    ActiveWorkbook.Save
    autosave = False
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If LogSheet Is Nothing Then Exit Sub
    If LogSheet Is Sh Then Exit Sub
    Set CurrentSheet = Sh
    'Not sure the correct way to do this; below works okay enough...
    oldContents = ActiveCell.Value
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If LogSheet Is Nothing Then Exit Sub
    '***DO NOT REMOVE THE NEXT LINE OR EXCEL WILL HATE YOU.***
    If LogSheet Is Sh Then Exit Sub
    Dim r As Long, tmp1 As String, L0 As Long, L1 As Long, tgt As Variant, tmp2
    Dim ub As Long, e As Long
    tgt = Target
    r = LogSheet.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
    LogSheet.Cells(r, 1).Value = Now
    On Error Resume Next
    If (VarType(oldContents) And vbArray) = vbArray Then
        ub = UBound(oldContents, 2)
        e = Err.Number
        Select Case e
            Case 0  'no error; multi-col array
                For L0 = LBound(oldContents, 1) To UBound(oldContents, 1)
                    For L1 = LBound(oldContents, 2) To ub
                        tmp1 = tmp1 & CStr(oldContents(L0, L1))
                        If (L0 <> UBound(oldContents, 1)) Or (L1 <> ub) Then
                            tmp1 = tmp1 & ","
                        End If
                    Next
                Next
            Case 9  'Ubound subscript too high; single-col array
                ub = UBound(oldContents)
                tmp1 = oldContents(LBound(oldContents))
                For L0 = LBound(oldContents) + 1 To ub
                    tmp1 = tmp1 & "," & CStr(oldContents(L0))
                Next
            Case Else
                Err.Raise e
        End Select
    Else
        tmp1 = CStr(oldContents)
    End If
    If (VarType(tgt) And vbArray) = vbArray Then
        ub = UBound(tgt, 2)
        e = Err.Number
        Select Case e
            Case 0  'no error; multi-col array
                For L0 = LBound(tgt, 1) To UBound(tgt, 1)
                    For L1 = LBound(tgt, 2) To ub
                        tmp2 = tmp2 & CStr(tgt(L0, L1))
                        If (L0 <> UBound(tgt, 1)) Or (L1 <> ub) Then
                            tmp2 = tmp2 & ","
                        End If
                    Next
                Next
            Case 9  'Ubound subscript too high; single-col array
                ub = UBound(tgt)
                tmp2 = tgt(LBound(tgt))
                For L0 = LBound(tgt) + 1 To ub
                    tmp2 = tmp2 & "," & CStr(tgt(L0))
                Next
            Case Else
                Err.Raise e
        End Select
    Else
        tmp2 = CStr(Target.Value)
    End If
    On Error GoTo 0
    LogSheet.Cells(r, 2).Value = "Changed " & Sh.Name & "!" & Target.Address & " from '" & tmp1 & "' to '" & tmp2 & "'"
    LogSheet.Cells.Columns.AutoFit
    oldContents = Target.Value
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If LogSheet Is Sh Then Exit Sub
    oldContents = Target.Value
End Sub

 

[deadlyliquidx]

That looks way too much from what im after and I cant even read it to fix it for my file.
Anyways, this is what I have abet its a bit slow.
Now I have a new problem, somewhat related, so you can see the target to check the change is Z and af columns, now what returned is whatever value is in column D of whatever row that change was made.
Column D contains all the index numbers.
so you see wehere all the .offset values are being recorded in the log.
I want something to say something like .Offset(1, 5).Value = the value in column D in the same row as the target value changed.
This would finish what I need.
Thanks!

Public varPValue As Variant


Private Sub Worksheet_Change(ByVal Target As Range)
Dim Errb As Integer




    On Error GoTo ErrTrap:
    If Target.Value <> varPValue And Intersect(Target, Range("z:z , af:af")) Then
      With Sheets("log").Cells(65000, 1).End(xlUp)
        .Offset(1, 0).Value = Application.UserName
        .Offset(1, 1).Value = Target.Address(1, 0)
        .Offset(1, 2).Value = varPValue
        .Offset(1, 3).Value = Target.Value
        .Offset(1, 4).Value = Now()
      End With
    End If
    Exit Sub
ErrTrap:
  ErrNum = Err
  
  If ErrNum = 13 Then
    '*** Multiple cells have been selected, treat them as one merged group*****
    Resume Next
  End If
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    varPValue = Target.Value

End Sub