excel 为每个单元格更改更新日期单元格

wkyowqbh 于 2023-01-27 发布在其他

关注(0)|答案(2)|浏览(253)

我试图自动化的日期响应列在Excel从不同的用户。我已经更新了代码基础一些研发从不同的博客，但停留在一个地方。我的代码如下。同样是能够记录的日期变化的一个单元格在下一个单元格。因为我只想第一次更新的日期，这是做得很好。但是，在情况下，如果用户正在删除响应，日期仍然存在，因此“目标。偏移量（0，1）。清除内容”是不工作的。请帮助更新代码。
代码中的我的要求总结如下：

应更新下一个单元格中单元格的更改日期（偏移量（0，1））
如果一个单元格发生多次变更，则只记录首次响应日期，不应覆盖之前的日期。
当用户删除回复时，也应删除日期。（代码将在Excel中运行，大约有2000行，大约10-20个用户将访问工作表。）

Dim xRg As Range, xCell As Range
On Error Resume Next
If (Target.Count = 1) Then
If Not Intersect(Target, Application.ActiveSheet.Range("U:U,W:W,Y:Y,AA:AA,AC:AC,AE:AE,AG:AG,AI:AI")) Is Nothing Then
Application.EnableEvents = False
For Each xCell In xRg
        If VBA.IsEmpty(xCell.Value) Then
            If Target.Offset(0, 1) = "" Then
            Target.Offset(0, 1) = Now
            End If
            Else
            Target.Offset(0, 1).ClearContents
        End If
    Next
    Application.EnableEvents = True
End If
End If
End Sub

excel

来源：https://stackoverflow.com/questions/75206598/update-date-cell-for-each-cell-change

2条答案

按热度按时间

ny6fqffe1#

我觉得你是为了这个

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
        
    Dim xRg As Range
        Set xRg = Intersect(Target, Range("U:U,W:W,Y:Y,AA:AA,AC:AC,AE:AE,AG:AG,AI:AI")) ' set the range of possible interest
        
        If Not xRg Is Nothing Then ' if changed range crosses the one of interest
        
            On Error GoTo SafeExit
            Application.EnableEvents = False
            
            Dim xCell As Range
            For Each xCell In xRg ' loop through the changed range of interest
                Select Case True
                
                    Case VBA.IsEmpty(xCell.Value) ' if current cell is empty
                        xCell.Offset(0, 1).ClearContents ' delete the date
                    
                    Case VBA.IsEmpty(xCell.Offset(0, 1).Value) ' if no date next
                        xCell.Offset(0, 1).Value = Now 'write the date
                    
                End Select
            Next
                
        End If

SafeExit:
    Application.EnableEvents = True

End Sub

一些假设/评论：

处理多个单元格更改的情况
On Error Resume Next没有用，请改用On Error GoTo SomeLabel，并确保在出现任何错误时恢复Application.EnableEvents = True
代码中的For Each xCell In xRg假设循环通过尚未设置的范围（xRg

赞(0）回复(0）举报 2023-01-27

pkln4tw62#

您没有设置xRg。
由于On error resume next，您未收到错误。
重构思路：将代码放入通过目标范围的单个Sub中

阅读一下潜艇的名字就知道它在干什么
你可以从其他表中重复使用它

我会像这样更新代码：

Private Sub Worksheet_Change(ByVal Target As Range)

'On Error Resume Next       'don't use this - you won't be able to fix errors

setChangeDate Target
            
End Sub

你可以把它放在一个普通的模块中--或者把它放在工作表模块中。

Public Sub setChangeDate(rgChanged As Range)

Dim wsToCheck As Worksheet
Set wsToCheck = rgChanged.Parent

Dim rgToCheck As Range
Set rgToCheck = wsToCheck.Range("U:U,W:W,Y:Y,AA:AA,AC:AC,AE:AE,AG:AG,AI:AI")

Application.EnableEvents = False

Dim xCell As Range

For Each xCell In rgChanged
    If Not Intersect(xCell, rgToCheck) Is Nothing Then
        'xcell is within range
        If xCell.Value <> "" And xCell.Offset(0, 1) = "" Then
            'first entry >> set date
            xCell.Offset(0, 1) = Now
        ElseIf xCell.Value = "" Then
            'entry has been removed >> remove date
            xCell.Offset(0, 1).ClearContents
        End If
    End If
Next

Application.EnableEvents = True

End Sub

有一个额外的范围rgToCheck使它更清楚的情况下，必须更新您的工作表列。
如果放入一个普通的模块中，那么传递rgToCheck也是有意义的，因为它可能因表而异。

赞(0）回复(0）举报 2023-01-27

我来回答

excel 为每个单元格更改更新日期单元格

2条答案

相关问题

热门标签

最新问答