require code for audit trails using vba code

Question

I have a sheet named mapping and it contains 3 columns namely Fundcode(b3),subsription rate(c3) and redemption rate(d3)

so values are entered from row 4 for these headers..i wanted audit trails for values entered in these cells with the user name .

I tried with some code,but it did not help me. As i am new to macro, i do not know how to resolve it

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim strAddress As String
    Dim val
    Dim dtmTime As Date
    Dim Rw As Long

    If Intersect(Target, Range("B4:D4")) Is Nothing Then Exit Sub

    dtmTime = Now()
    val = Target.value
    strAddress = Target.Address

    Rw = Sheets("shtMapping").Range("B" & Rows.Count).End(xlUp).Row + 1
    With Sheets("shtMapping")
        .Cells(Rw, 1) = strAddress
        .Cells(Rw, 2) = val
        .Cells(Rw, 3) = dtmTime
    End With

End Sub

-

Fund Code   Subscription Rate   Redemption Rate
SGIS            0.16                     0.60
SPED            0.36                     0.40
SPEH            0.05                     0.12

so when I go and update subscription rate for SPED as 0.15 ,I need previous value 0.36 being captured and who had changed this existing value (username)

Answer 1

I created same headings in the mapping sheet from cells E to F and made it as hidden in the sheet .So when ever edit is pressed it copies to hidden and makes a compare to Audit sheet and replaces them,

Sub CopyCurrentTable()

Application.ScreenUpdating = False
With shtMapping
    .Range("E4:G1000").ClearContents
    .Range("B4:D" & GetLastRow(shtMapping, "B", 4)).Copy
    .Range("E4").PasteSpecial xlPasteAll
    Application.CutCopyMode = False
End With

End Sub

Sub SaveMapping()

Dim bValidTable As Boolean: bValidTable = True
Dim i As Long

With shtMapping
    If .Shapes("shaEditMode").Visible Then
        .Unprotect g_sPassword
        .Range("B4:D103").Sort .Range("B4"), xlAscending
        For i = 4 To 103
            If .Range("B" & i).value = "" And .Range("C" & i).value = "" And .Range("D" & i).value = "" Then
                Exit For
            ElseIf .Range("B" & i).value = "" Or .Range("C" & i).value = "" Or .Range("D" & i).value = "" Then
                MsgBox "The table is missing critical information." & vbNewLine & "Please ensure all columns are populated in all rows of data.", vbCritical, "Error"
                bValidTable = False
                Exit For
            End If

            If .Range("B" & i).value = .Range("B" & i + 1) Then
                MsgBox "The table contains duplicate Fund Codes." & vbNewLine & "Please ensure Fund Codes are unique and try again.", vbCritical, "Error"
                bValidTable = False
                Exit For
            End If
        Next i
        If bValidTable Then
            With .Range("B4:D103")
                .Locked = True
                .Interior.Color = vbWhite
            End With
            .Shapes("shaEditMode").Visible = False

            'Identify Changes and plot to Audit table
            Call LogAuditTrail
            Call OpenMain
            ThisWorkbook.Save
        End If
        .Protect g_sPassword
    Else
        Call OpenMain
    End If
End With

End Sub

Sub LogAuditTrail()

Dim colOld As Collection
Dim colNew As Collection
Dim objNew As ClsMapping
Dim objOld As ClsMapping
Set colOld = getMappingData("E")
Set colNew = getMappingData("B")
Dim sTS As String

sTS = Format(Now, "dd-mmm-yyy hh:mm:ss")

For Each objNew In colNew
    'Detect Items Changed
    If ItemIsInCollection(colOld, objNew.getKey) Then
        Set objOld = colOld(objNew.getKey)
        If objNew.isDifferent(objOld) Then
            Call PlotToAudit(objNew, objOld, sTS, "Change")
        End If
    Else
        'Detect Items Added
        Set objOld = New ClsMapping
        Call PlotToAudit(objNew, objOld, sTS, "New")
    End If
Next objNew

'Detect Items removed
For Each objOld In colOld
    If Not ItemIsInCollection(colNew, objOld.getKey) Then
        Set objNew = New ClsMapping
        Call PlotToAudit(objNew, objOld, sTS, "Removed")
    End If
Next objOld

End Sub Sub PlotToAudit(obj1 As ClsMapping, obj2 As ClsMapping, sTS As String, sType As String)

Dim lRow As Long
lRow = shtAudit.Range("B1048576").End(xlUp).Row

If lRow = 3 Then
    lRow = 5
ElseIf lRow = 1048576 Then
    MsgBox "Audit sheet is full. Contact Support." & vbNewLine & "No audit trail will be saved", vbCritical, "ERROR"
    Exit Sub
Else
    lRow = lRow + 1
End If

With shtAudit
    .Unprotect g_sPassword
    .Range("B" & lRow).value = Application.UserName & "(" & Environ("USERNAME") & ")"
    .Range("C" & lRow).value = sTS
    .Range("D" & lRow).value = sType

    Select Case sType
        Case "Removed"
            .Range("E" & lRow).value = ""
            .Range("F" & lRow).value = ""
            .Range("G" & lRow).value = ""
            .Range("H" & lRow).value = obj2.FundCode
            .Range("I" & lRow).value = obj2.Subs
            .Range("J" & lRow).value = obj2.Reds
        Case "New"
            .Range("E" & lRow).value = obj1.FundCode
            .Range("F" & lRow).value = obj1.Subs
            .Range("G" & lRow).value = obj1.Reds
            .Range("H" & lRow).value = ""
            .Range("I" & lRow).value = ""
            .Range("J" & lRow).value = ""
        Case "Change"
            .Range("E" & lRow).value = obj1.FundCode
            .Range("F" & lRow).value = obj1.Subs
            .Range("G" & lRow).value = obj1.Reds
            .Range("H" & lRow).value = obj2.FundCode
            .Range("I" & lRow).value = obj2.Subs
            .Range("J" & lRow).value = obj2.Reds
    End Select
    With .Range("B" & lRow & ":J" & lRow)
        .Interior.Color = vbWhite
        .Borders.LineStyle = xlContinuou
    End With
    .Protect g_sPassword
End With

End Sub