VBA Worksheet_change添加新行时，插入今天的date
我试图在我的数据库的表上使用公式= Today（），当我尝试在第二天插入一个新行时，整个数据甚至以前的date已被replace为当天的date。 有没有办法阻止它？ 或者是否有可能使用worksheet_change来更新date的列当新行被插入，新的angular色的date列将有当天的date和第二天，当我再次更新它不会被replace？ 请告知谢谢
ZQ7，这个答案正如我在评论中提到的那样，find= TODAY()公式单元格并将它的值粘贴到当前单元格中。 然后你可以添加你的新行并运行其余的代码
Option Explicit Sub prevenddate() Dim mert As Range Dim wb As Workbook Dim ws As Worksheet Set wb = ThisWorkbook Set ws = wb.Sheets("Sheet1") Cells.Find(What:="=TODAY()", After:= _ ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate ActiveCell.Copy ActiveCell.PasteSpecial xlPasteValues End Sub
这里是所需的答案！
这下面的代码，首先查找工作表中的任何=TODAY()公式，如果结果是今天的date，它不会做任何事情。 但是，如果它不同于今天的date，那么它只是做Paste Values
Private Sub Worksheet_Change(ByVal Target As Range) Dim wb As Workbook Dim ws As Worksheet Dim myRw As Long, myCl As Long Set wb = ThisWorkbook Set ws = wb.Sheets("Sheet1") On Error GoTo 10 myRw = ActiveCell.Row myCl = ActiveCell.Column ws.Cells.Find(What:="=TODAY()", After:= _ ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Activate If ActiveCell.Value <> Date Then Cells.Find(What:="=TODAY()", After:= _ ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Activate ActiveCell.Copy ActiveCell.PasteSpecial xlPasteValues Else End If 10 ws.Cells(myRw, myCl).Offset(-1, 0).Activate Application.CutCopyMode = False End Sub
请尝试这个代码
Public Function MyToday() As Date MyToday = CDate(Now() \ 1) End Function
应该被称为像
MyToday()
将下面的代码放在Sheet Module上。
如果从Row2开始在列B中input某些内容，代码将在列A中插入date。
Private Sub Worksheet_Change(ByVal Target As Range) Dim r As Long On Error GoTo SkipError If Target.Column = 2 And Target.Row > 1 Then Application.EnableEvents = False r = Target.Row If Target <> "" Then If Cells(r, "A") = "" Then Cells(r, "A") = Date End If Else Cells(r, "A") = "" End If End If SkipError: Application.EnableEvents = True End Sub
从确定用户是否通过breetdj 添加或删除行我写这个代码。 尝试把它放在表单模块中：
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Static LR As Long Dim Table as range Set Table = Me.ListObjects(1).DataBodyRange If LR = 0 Then LR = Table.Rows.Count Exit Sub End If If Table.Rows.Count < LR Or Table.Cells(Table.Rows.Count, 1) <> "" Then Exit Sub Table.Cells(Table.Rows.Count, 1) = Date LR = LR + 1 End Sub
将“ListObjects（1）”更改为表格的名称，然后更改所需列的列号