vba - 当多个单元格一起更改时，对每行更改添加时间戳(例如使用自动填充)

Question

Screen shot of what I want:

我想在发生更改时为每一行添加时间戳，以便我可以将在特定时间后更新的所有行上传到中央文件。由于一项 Assets 的每个子组件可能有多行，因此用户可以填写一行并自动填充/复制粘贴到下面的相关行。行可能不在连续范围内(例如，过滤时)。

我得到的代码非常适合一次更改一个单元格，并且适用于一定范围，但速度非常慢。

该子程序由 worksheet_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

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

此解决方案假设如下:

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

更改日期、更改人和最后更改单元格按照提供的图片。

AC、 Z 列的

预订日期、BkdDte 更改 和 迭代和 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

如果您对此过程中使用的资源有任何疑问，请告诉我。