自動填充在2個細胞的日期和時間，當用戶在相鄰小區中進入信息

Question

我有以下代碼這會自動填入日期列B中一旦我在列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列

行，所以我發現在尋找什麼即時的，但它需要稍加修改其中的日期和時間設定。下面 是代碼

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列有日期，而不是列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

，如果你想：

• 把當前日期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 

而如果你想：

• 把當前日期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聲明，確保您處理任何可能的錯誤。

但在這種情況下，是它僅限於一個子的最後兩個語句，我認爲這有利於代碼的可讀性是一個很好的權衡，而無需實際失去了控制