使用vba代码要求进行审计跟踪的代码

Question

我有一个名为映射的表格，它包含3列，即基金代码(B3)、子购买率(C3)和赎回率(D3)。

因此，值是从第4行输入的，用于这些标题.我希望对在这些单元格中输入的带有用户名的值进行审计跟踪。

我试过一些代码，但对我没有帮助。由于我刚接触宏，我不知道如何解决这个问题。

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

因此，当我去更新速度为0.15的订阅率时，我需要捕获以前的值0.36，并且是谁更改了这个现有值(用户名)

Answer 1

我在从单元格E到F的映射表中创建了相同的标题，并将其作为隐藏在工作表.So中，当编辑被按下时，将其复制到隐藏中，并将其与审计表进行比较并进行替换，

亚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

结束子对象

亚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

结束子对象

亚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 (obj1作为ClsMapping，obj2作为ClsMapping，sTS作为String，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

结束子对象

Answer 2

我创建了一个新的工作表审核。

我有两个按钮，保存，编辑和保存在映射表。

因此，当用户单击“编辑”按钮时，将启用数据。

一旦启用了数据，我就会将值复制到不同的工作表中，并捕获企业。

下面是我做过的代码，它运行得很好，

亚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

结束子对象