使用 vba 代码需要审计跟踪代码

Question

我有一个 sheet 命名映射，它包含 3 列，即基金代码 (b3)、认购率 (c3) 和赎回率 (d3)

所以这些值是从第 4 行输入的 headers..我想对这些单元格中使用用户名输入的值进行审计跟踪。

我尝试了一些代码，但它没有帮助我。由于我是宏的新手，我不知道如何解决它

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

所以当我将 SPED 的订阅率更新为 0.15 时，我需要捕获之前的值 0.36 以及更改此现有值（用户名）的人

Answer 1

我创建了一个新的 sheet 审核。

我在映射 sheet 中有两个按钮保存编辑和保存。

所以当用户点击编辑按钮时，数据被启用。

启用数据后，我将值复制粘贴到另一个 sheet 并捕获条目。

下面是我编写的一段代码，它运行良好，

子 EditMapping()

 With shtMapping
    .Unprotect g_sPassword

    With .Range("B4:D103")
        .Locked = False
        .Interior.Color = vbYellow
         shtMapping.Range("B3:D103").Copy
         ThisWorkbook.Worksheets("Audit").Activate
         ThisWorkbook.Worksheets("Audit").Cells(1, 1).Select
         ActiveSheet.Paste
         shtMapping.Activate

    End With
    .Shapes("shaEditMode").Visible = True
    .Protect g_sPassword
End With

结束子

Answer 2

我在从单元格 E 到 F 的映射 sheet 中创建了相同的标题，并将其隐藏在 sheet 中。因此，当按下编辑时，它会复制到隐藏并进行比较审核 sheet 并替换它们，

子 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

结束子

子保存映射()

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

结束子

子 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

结束子 Sub PlotToAudit（obj1 作为 ClsMapping，obj2 作为 ClsMapping，sTS 作为字符串，sType 作为字符串）

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

结束子

使用 vba 代码需要审计跟踪代码

require code for audit trails using vba code

excel

vba

auditing