Question

我希望在进行更改时为每一行添加时间戳，这样我就可以将一段时间后更新的所有行上传到中心文件。由于每个子组件的一个资产可能有多行，因此用户可以填写一行并自动填充/复制粘贴到下面的相关行。行可能不在连续范围内（例如，在过滤时）。

我所获得的代码非常适合一次更改一个单元格，但它适用于范围但速度极慢。

这个子由workheet_change调用，如下所示。

    Sub SetDateRow(Target As Range, Col As String)

    Dim TargetRng As Range
    Dim LastCol, LastInputCol As Integer
     With ActiveSheet
    LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
    End With

     For Each TargetRng In Target.Cells

     If TargetRng.Cells.Count > 1 Then
    Application.EnableEvents = True
    Exit Sub
    Else
Application.EnableEvents = False

Cells(TargetRng.Row, LastCol - 2) = Now()
 Cells(TargetRng.Row, LastCol - 1).Value = Environ("username")
Cells(TargetRng.Row, LastCol).Value = Target.Address

End If
Next

       Application.EnableEvents = True
 End Sub

Target.Cells.Address返回范围（包括不可见的单元格），但我无法弄清楚如何将其拆分为可以循环的单个可见单元格。

     Private Sub Worksheet_Change(ByVal Target As Range)

                On Error GoTo Errorcatch


                Dim TargetRng As Range

                Dim LastCol, LastInputCol, LastRow As Integer
                Dim LastInputColLetter As String
                Dim ContinueNewRow
                With ActiveSheet
                LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
                LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
                End With
                LastInputCol = LastCol - 3

                If LastInputCol > 26 Then
                    LastInputColLetter = Chr(Int((LastInputCol - 1) / 26) + 64) & Chr(((LastInputCol - 1) Mod 26) + 65)
                Else
                    LastInputColLetter = Chr(LastInputCol + 64)
                End If

                 For Each TargetRng In Target.Cells


                    If TargetRng.Row <= 2 Then
                        Exit Sub
                    End If


                If TargetRng.Column <= LastInputCol Then

                    SetDateRow Target, LastCol - 3


                    If TargetRng.Count = 1 Then



                    Application.EnableEvents = False
                '
                   Dim cmt As String
                '    If Target.Value = "" Then
                '    Target.Value = " "
                '
                '    End If
                '----------------------------------------------------------------
                If Intersect(TargetRng, Range("AC3:AC10000")) Is Nothing Then ' need to make column into variables in the code based on column name

                 Application.EnableEvents = True
                 Else

                    Application.EnableEvents = False
                    Cells(TargetRng.Row, "Z") = Now() 'Date booking was made column
                    Cells(TargetRng.Row, "AD").Value = Cells(Target.Row, "AD").Value + 1 ' iteration column

                End If
                '----------------------------------------------------------------

                    If TargetRng.Comment Is Nothing Then
                        cmt = Now & vbCrLf & Environ("UserName") & " *" & TargetRng.Value & "*"
                    Else
                         cmt = Now & vbCrLf & Environ("UserName") & " *" & TargetRng.Value & "* " & TargetRng.Comment.Text
                    End If

                        With TargetRng
                            .ClearComments
                            .AddComment cmt
                        End With


                         End If
                   End If

                        Application.EnableEvents = True
                Next

                Exit Sub

     Errorcatch:
                    MsgBox Err.Description
                        Application.EnableEvents = True


                End Sub

Answer 1

您可以使用以下内容：

Sub SetDateRow(Target As Range, Col As String)

    Dim TargetRng             As Range
    Dim LastCol               As Long
    Dim LastInputCol          As Long
    Dim bEvents               As Boolean

    With ActiveSheet
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
    End With
    bEvents = Application.EnableEvents
    Application.EnableEvents = False
    If Target.Cells.Count > 1 Then

        For Each TargetRng In Target.SpecialCells(xlCellTypeVisible).Areas

            Cells(TargetRng.Row, LastCol - 2).Resize(TargetRng.Rows.Count, 1).Value = Now()
            Cells(TargetRng.Row, LastCol - 1).Resize(TargetRng.Rows.Count, 1).Value = Environ("username")
            Cells(TargetRng.Row, LastCol).Resize(TargetRng.Rows.Count, 1).Value = Target.Address

        Next

    Else
            Cells(Target.Row, LastCol - 2).Value = Now()
            Cells(Target.Row, LastCol - 1).Value = Environ("username")
            Cells(Target.Row, LastCol).Value = Target.Address

    End If

    Application.EnableEvents = bEvents
End Sub

但请确保在更改事件中循环之前或之后调用它，而不是像现在这样在其中调用它！

Answer 2

我对您的代码进行了一些调整（请参阅代码中的注释）

此解决方案假设如下：

示例数据有两行标题，要更新的字段具有位于行1 的以下标题（如果需要，请调整代码中的相应行）：

Date Change Made，Who Made Change和Last Cell Changed按照提供的图片。

{p> Booked Date，BkdDte Change和Iteration分别列为AC，Z和AD （此名称用于测试目的，将代码更改为实际名称）

我还将两个过程组合成一个共同的过程，以避免循环两次更改范围的单元格的低效方法。如果他们必须保持分离并进行必要的调整，请告诉我。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Wsh As Worksheet, rCll As Range
Dim iDteChn  As Integer, iWhoChn As Integer, iLstCll As Integer
Dim iBkdDte As Integer, iBkdChn As Integer, iBkdCnt As Integer
Dim sCllCmt As String
Dim lRow As Long
On Error GoTo ErrorCatch

    Rem Set Application Properties
    Application.ScreenUpdating = False  'Improve performance
    Application.EnableEvents = False    'Disable events at the begining

    Rem Set Field Position - This will always returns Fields position
    Set Wsh = Target.Worksheet
    With Wsh
        iDteChn = WorksheetFunction.Match("Date Change Made", .Rows(1), 0)
        iWhoChn = WorksheetFunction.Match("Who Made Change", .Rows(1), 0)
        iLstCll = WorksheetFunction.Match("Last Cell Changed", .Rows(1), 0)
        iBkdDte = WorksheetFunction.Match("Booked Date", .Rows(1), 0)       'Column of field "Booked date" (i.e. Column `AC`)
        iBkdChn = WorksheetFunction.Match("BkdDte Change", .Rows(1), 0)     'Column of field "Booked date changed" (i.e. Column `Z`)
        iBkdCnt = WorksheetFunction.Match("Iteration", .Rows(1), 0)         'Column of field "Iteration" (i.e. Column `AD`)
    End With

    Rem Process Cells Changed
    For Each rCll In Target.Cells
        With rCll
            lRow = .Row

            Rem Exclude Header Rows
            If lRow <= 2 Then GoTo NEXT_Cll

            Rem Validate Field Changed
            Select Case .Column
            Case Is >= iLstCll:                         GoTo NEXT_Cll
            Case iDteChn, iWhoChn, iBkdChn, iBkdCnt:    GoTo NEXT_Cll
            Case iBkdDte
                Rem Booked Date - Set Count
                Wsh.Cells(lRow, iBkdChn) = Now()
                Wsh.Cells(lRow, iBkdCnt).Value = Cells(.Row, iBkdCnt).Value + 1
            End Select

            Rem Update Cell Change Details
            Wsh.Cells(lRow, iDteChn).Value = Now()
            Wsh.Cells(lRow, iWhoChn).Value = Environ("username")
            Wsh.Cells(lRow, iLstCll).Value = .Address

            Rem Update Cell Change Comments
            sCllCmt = Now & vbCrLf & Environ("UserName") & " *" & .Value & "*"
            If Not .Comment Is Nothing Then sCllCmt = sCllCmt & .Comment.Text
            .ClearComments
            .AddComment sCllCmt

        End With

NEXT_Cll:
    Next

    Rem Restate Application Properties
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    Exit Sub

ErrorCatch:
    MsgBox Err.Description
    Rem Restate Application Properties
    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub

如果您对此过程中使用的资源有任何疑问，请与我们联系。

时间戳记在多个单元格一起更改时更改的每一行（例如，使用自动填充）

2 个答案: