当用户在相邻单元格中input信息时，自动填充2个单元格中的date和时间

我有以下代码将自动填充列B中的date，一旦我在列A中添加值

Private Sub Worksheet_Change(ByVal Target As Range) Dim A As Range, B As Range, Inte As Range, r As Range Set A = Range("A:A") Set Inte = Intersect(A, Target) If Inte Is Nothing Then Exit Sub Application.EnableEvents = False For Each r In Inte If r.Offset(0, 1).Value = "" Then r.Offset(0, 1).Value = Date & " " & Time = "hh:mm:ss AM/PM" End If Next r Application.EnableEvents = True End Sub 

即时通讯寻找的是也添加当前时间列C.

好，所以我find了即时寻找，但它需要很less修改date和时间设置。 下面是代码

 Private Sub Worksheet_Change(ByVal Target As Range) Dim A As Range, B As Range, Inte As Range, r As Range Set A = Range("D:D") Set Inte = Intersect(A, Target) If Inte Is Nothing Then Exit Sub Application.EnableEvents = False For Each r In Inte If r.Value > 0 Then r.Offset(0, -3).Value = Date r.Offset(0, -3).NumberFormat = "dd-mm-yyyy" r.Offset(0, -2).Value = Time r.Offset(0, -2).NumberFormat = "hh:mm:ss AM/PM" Else r.Offset(0, -3).Value = "" r.Offset(0, -2).Value = "" End If Next r Application.EnableEvents = True End Sub 

自动填充列E与date，而不是列A和自动填充列F与时间，而不是B列

如果可能的话，我试图有相同的过程，但在同一张纸上的另一个单元格。

Answer 1

虽然你可能会看到使用SpecialCells来做到这一点，而不是一个循环，一个简单的MOD你的代码将是：

每范围区域的一次性方法

 Private Sub Worksheet_Change(ByVal Target As Range) Dim A As Range, B As Range, Inte As Range, r As Range Set A = Range("A:A") Set Inte = Intersect(A, Target) If Inte Is Nothing Then Exit Sub Application.EnableEvents = False On Error Resume Next For Each r In Inte.Areas r.Offset(0, 1).Cells.SpecialCells(xlCellTypeBlanks) = Date r.Offset(0, 2).Cells.SpecialCells(xlCellTypeBlanks) = Time Next r Application.EnableEvents = True End Sub 

最初的答案

 Private Sub Worksheet_Change(ByVal Target As Range) Dim A As Range, B As Range, Inte As Range, r As Range Set A = Range("A:A") Set Inte = Intersect(A, Target) If Inte Is Nothing Then Exit Sub Application.EnableEvents = False For Each r In Inte If r.Offset(0, 1).Value = vbNullString Then r.Offset(0, 1).Value = Date If r.Offset(0, 2).Value = vbNullString Then r.Offset(0, 2).Value = Time Next r Application.EnableEvents = True End Sub 

Answer 2

如果你想：

• 将当前date放在Target相邻列空白单元格中

• 将当前时间放在Target相邻列空白单元格的相邻单元格中

然后去如下：

 Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Range("A:A"), Target).Address <> Target.Address Then Exit Sub '<--| exit if all target cells aren't in column "A" Application.EnableEvents = False If WorksheetFunction.CountBlank(Target.Offset(, 1)) = 0 Then Exit Sub '<--| exit if no blank cells in target adjacent column With Target.Offset(, 1).SpecialCells(xlCellTypeBlanks) '<--| reference blank cells in target adjacent column .Value = Date '<--| set referenced cells value to the current date .Offset(, 1).Value = Time '<--| set referenced cells adjacent ones value to the current time End With Application.EnableEvents = True End Sub 

而如果你想：

• 将当前date放在Target相邻列空白单元格中

• 将当前时间放在Target两列中，偏移空白单元格

然后去如下：

 Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Range("A:A"), Target).Address <> Target.Address Then Exit Sub '<--| exit if all target cells aren't in column "A" Application.EnableEvents = False On Error Resume Next Target.Offset(, 1).SpecialCells(xlCellTypeBlanks).Value = Date '<--| set target adjacent column blank cells to the current date Target.Offset(, 2).SpecialCells(xlCellTypeBlanks).Value = Time '<--| set target two columns offset blank cells to the current time Application.EnableEvents = True End Sub 

在那里的On Error Resume Next是为了避免两个不同If WorksheetFunction.CountBlank(someRange) Then someRange.SpecialCells(xlCellTypeBlanks).Value = someValue语句

通常情况下，您将避免On Error Resume Next语句，并确保您处理任何可能的错误。

但在这种情况下，被限制在一个子的最后两个语句中，我认为这是一个很好的代码可读性的折衷，而不会实际上失去它的控制