Shared Excel File That Sends Daily Change Log

[Logit]

Dim vOldVal 'Must be at top of module

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim strUserName As String
    Dim xFormula As Boolean
    Dim xDate As Boolean
    Dim xHead As Range
    Dim xTitle As Range
    Set xHead = Sheets("Track_Changes").Range("B3:H3")
    strUserName = Application.UserName
    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
    On Error Resume Next
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    If IsEmpty(vOldVal) Then vOldVal = "[empty cell]"
    xFormula = Target.HasFormula
    xDate = IsDate(Target)
    With Sheets("Track_Changes")
        .Unprotect Password:="Password"
        If .Range("B2") = vbNullString Then
            xHead = Array("DATE OF CHANGE", "TIME OF CHANGE", "SHEET NAME", "CELL CHANGED", "CHANGE BY", "OLD VALUE", "NEW VALUE")
            Sheets("Track_Changes").Columns(1).ColumnWidth = 3
            .Range("B1").Value = "Track Changes"
            .Range("B1").Font.Size = 18
            With xHead
                .Interior.Color = RGB(30, 139, 195)
                .Font.Color = vbWhite
                .Font.Bold = True
            End With
            With xHead.Borders(xlInsideVertical)
                .Color = vbWhite
                .Weight = xlMedium
            End With
        End If
        With .Cells(.Rows.Count, 2).End(xlUp)(2, 1)
            .Borders(xlInsideVertical).Color = RGB(255, 191, 191)
            .Borders(xlInsideVertical).Weight = xlMedium
            .Value = Date
            .Offset(0, 1) = Format(Now, "hh:mm:ss")
            .Offset(0, 2) = Target.Parent.Name
            .Offset(0, 3) = Target.Address
            .Offset(0, 4) = strUserName
            .Offset(0, 5) = vOldVal
            With .Offset(0, 6)
                If xFormula = True Then
                    .ClearComments
                    .AddComment.Text Text:="Cell is bold as value contains a formula"
                End If
                If xDate = True Then
                    .NumberFormat = "dd/mm/yyyy"
                End If
                .Value = Target
                .Font.Bold = xFormula
                If IsEmpty(Target) Then .Value = "[empty cell]"
            End With
        End With
        .Cells.Columns.AutoFit
        .Cells.Columns.HorizontalAlignment = xlLeft
        n = Sheets("Track_Changes").Range("B:B").Cells.SpecialCells(xlCellTypeConstants).Count - 1
        With Sheets("Track_Changes").Range("B4:H" & n + 2)
            .Borders(xlInsideHorizontal).Color = RGB(30, 139, 195)
            .Borders(xlInsideHorizontal).Weight = xlThin
            .Borders(xlInsideVertical).Color = RGB(200, 200, 200)
            .Borders(xlInsideVertical).Weight = xlThin
        End With
        .Protect Password:="Password"
    End With
    vOldVal = vbNullString
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    On Error GoTo 0
End Sub


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    On Error Resume Next
    If Selection.Cells.Count > 1 Then Exit Sub 'Avoid runtime error 7
    vOldVal = Target
End Sub