I created a log details sheet to track changes made in an excel spreadsheet, but my code is not returning the column/header name.

The column name should return the column where changes occurred. In this case, it would be employee status.

This is what my excel file looks like.

Here is my VBA Code

Dim lastRng

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If ActiveSheet.Name <> "logdetails" Then

        Application.EnableEvents = False
        
        Sheets("logdetails").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = ActiveSheet.Name & "-" & Target.Address(0, 0)
        Sheets("logdetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = Target.Address
        Sheets("logdetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = lastRng
        Sheets("logdetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = Target.Value
        Sheets("logdetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).Value = Environ("username")
        Sheets("logdetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 5).Value = Now
        Sheets("logdetails").Columns("A:H").AutoFit
        
        Application.EnableEvents = True

    End If
End Sub

Private Sub Workbook_Open()
    Set lastRng = ActiveCell
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    lastRng = Target.Value
End Sub

CodePudding user response：

Assuming that the column name is located in row 1:

Dim colName As String
colName = ActiveSheet.Cells(1, Target.Column)
Sheets("logdetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = colName 

CodePudding user response：

A Workbook Sheet Change: Logging Old and New (Application.Undo)

• This is a different approach that first writes the Target formulas (if no formula, it's equivalent to values) to an array, then uses Application.Undo, then writes the old Target values to another array, then writes back the new values and populates the log worksheet using the information from the arrays.
• It covers multiple cells when e.g. copy-pasting.
• It partially covers multi-ranges (discontinuous, incontiguous) i.e. you can only write to those by using VBA e.g. Range("A1,C3").Value = "Test". But the issue is that in the case of using VBA, Application.Undo will not work so you cannot get the old data in the 3rd column. Even worse, it might work wrong e.g. if you have previously changed something in a worksheet that is not affected by the code (in this case, only the log worksheet).

Sheet Module e.g. Sheet1

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Const dName As String = "LogDetails"
    Const HeaderRow As Long = 1
    Const dcCount As Long = 6
    
    On Error GoTo ClearError
    
    If Not TypeOf Sh Is Worksheet Then Exit Sub
    
    Dim sName As String: sName = Sh.Name
    If StrComp(sName, dName, vbTextCompare) = 0 Then Exit Sub
    
    Dim uName As String: uName = Environ("USERNAME")
    Dim tStamp As Date: tStamp = Now
    
    Dim aData: aData = GetCellAddresses(Target)
    Dim hData: hData = GetHeaders(Target, HeaderRow)
        
    Dim drCount As Long: drCount = UBound(aData)
    
    Dim nJag(): nJag = GetMultiRangeFormulas(Target)
    
    Application.EnableEvents = False
    
    Dim IsUndoClear As Boolean
    
    On Error Resume Next
        Application.Undo
        IsUndoClear = Err.Number = 0
    On Error GoTo ClearError
    
    Dim oJag(): Dim arg As Range, a As Long
    
    If IsUndoClear Then
        
        oJag = GetMultiRangeFormulas(Target)
    
        For Each arg In Target.Areas
            a = a   1
            arg.Value = nJag(a)
        Next arg
    
    End If
    
    Dim dData(): ReDim dData(1 To drCount, 1 To dcCount)
    
    Dim r As Long, c As Long, dr As Long
    
    For a = 1 To UBound(nJag)
        For r = 1 To UBound(nJag(a), 1)
            For c = 1 To UBound(nJag(a), 2)
                dr = dr   1
                dData(dr, 1) = dName & "-" & aData(dr)
                dData(dr, 2) = hData(dr)
                If IsUndoClear Then dData(dr, 3) = oJag(a)(r, c)
                dData(dr, 4) = nJag(a)(r, c)
                dData(dr, 5) = uName
                dData(dr, 6) = tStamp
            Next c
        Next r
    Next a
    
    Dim dws As Worksheet: Set dws = Sh.Parent.Sheets(dName)
    Dim dfcell As Range
    Set dfcell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
    Dim drg As Range: Set drg = dfcell.Resize(drCount, dcCount)
    
    drg.Value = dData
    drg.EntireColumn.AutoFit
    
ProcExit:
    On Error Resume Next
        If Not Application.EnableEvents Then Application.EnableEvents = True
    On Error GoTo 0
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "':" & Err.Description
    Resume ProcExit
End Sub

Standard Module e.g. Module1

Function GetHeaders( _
    ByVal mrg As Range, _
    Optional ByVal HeaderRow As Long = 1) _
As Variant

    Dim Data() As String: ReDim Data(1 To mrg.Cells.CountLarge)
    
    Dim mCell As Range, c As Long
    
    For Each mCell In mrg.Cells
        c = c   1
        Data(c) = mCell.EntireColumn.Cells(HeaderRow).Value
    Next mCell
    
    GetHeaders = Data

End Function

Function GetCellAddresses( _
    ByVal mrg As Range) _
As Variant
    
    Dim Data() As String: ReDim Data(1 To mrg.Cells.CountLarge)
    
    Dim mCell As Range, c As Long
    
    For Each mCell In mrg.Cells
        c = c   1
        Data(c) = mCell.Address(0, 0)
    Next mCell
    
    GetCellAddresses = Data

End Function

Function GetMultiRangeFormulas( _
    ByVal mrg As Range) _
As Variant
    Dim Jag(): ReDim Jag(1 To mrg.Areas.Count)
    Dim arg As Range, Data(), a As Long
    For Each arg In mrg.Areas
        a = a   1
        Data = GetRangeFormulas(arg)
        Jag(a) = Data
    Next arg
    GetMultiRangeFormulas = Jag
End Function

Function GetRangeFormulas( _
    ByVal rg As Range) _
As Variant
    Dim Data()
    If rg.Rows.Count * rg.Columns.Count = 1 Then
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Formula
    Else
        Data = rg.Formula
    End If
    GetRangeFormulas = Data
End Function