更改时复制并粘贴值

Question

我想写一个代码到：

• 将单元格A14复制到H列的第一行，
• 向下移动整列（最新数据在顶部），
• 然后在值更改时在I列中添加时间戳

但是我似乎无法使其正常运行。

我正在尝试实时跟踪这些值并创建时间序列图。

这需要自己执行。

有什么想法吗？

Private Sub Gain(ByVal target As Range)
Application.EnableEvents = True


Do While cell("A14") <> cell("H1")
If cell("H1") <> cell("A14") Then
Range("H1:J1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A14").Select
Selection.Copy
Range("H2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("A16").Select
Application.CutCopyMode = False
Selection.Copy
Range("I2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("B16").Select
Application.CutCopyMode = False
Selection.Copy
Range("J2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

Columns("I:I").Select
Application.CutCopyMode = False
Selection.NumberFormat = "[$-F400]h:mm:ss AM/PM"
Columns("J:J").Select
Selection.NumberFormat = "m/d/yyyy"
Columns("H:H").Select
Selection.NumberFormat = "$#,##0.00"
Next

结束子

Answer 1

这将跟踪所有更改并将当前时间粘贴到I列中。看起来您的复制和粘贴代码应该可以正常工作； 如果不是，请让我们知道您得到了什么（如果有）错误或结果。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
rng = Range("A:A")

If Intersect(Target, rng) Is Nothing Then
    'Do nothing
Else:

    If Target.Value <> Now Then

        Cells(Target.Row, 9).Value = Now
        Cells(Target.Row, 9).NumberFormat = "hh:mm:ss"
    Else
    End If
End If

End Sub