如何在VBA归档程序中为新增归档行添加时间戳？

我正在开发一款归档系统，现有VBA程序能将Interface工作表（日志界面）指定单元格的数据转移到Archives工作表的table_work列表对象，并新增一行。现在需要在归档表的专属列中插入当前时间戳，编写Timestamp子过程时遇到问题。现有代码如下：

现有Transfer代码 #

Sub Transfer()

    Dim config, itm, arr
    Dim rw As Range, listCols As ListColumns
    Dim shtForm As Worksheet
    

    Set shtForm = Worksheets("Interface") '<< data source

    With Sheets("Archives").ListObjects("table_work")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With

    'array of strings with pairs of "[colname]<>[range address]"
    config = Array("Unit<>A2", "Machine<>B2", "PC<>C2", "Software<>D2", "Who<>E2", "Why<>F2")  

    'loop over each item in the config array and transfer the value to the
    '  appropriate column
    For Each itm In config
        arr = Split(itm, "<>") ' split to colname and cell address
        rw.Cells(listCols(arr(0)).Index).Value = shtForm.Range(arr(1)).Value
    Next itm

End Sub

未完成的Timestamp代码 #

Sub Timestamp()

Dim timecol
Dim rw As Range, listCols As ListColumns
Dim shtForm As Worksheet

With Sheets("Archives").ListObjects("table_work")
        Set listCols = .ListColumns 

timecol = Array("When<>G2")

解决方案 #

方案1：直接在Transfer过程中整合时间戳逻辑

不需要单独维护Timestamp子过程，在数据转移完成后直接写入时间戳，代码更简洁高效：

Sub Transfer()
    Dim config, itm, arr
    Dim rw As Range, listCols As ListColumns
    Dim shtForm As Worksheet
    
    Set shtForm = Worksheets("Interface") '数据源
    
    With Sheets("Archives").ListObjects("table_work")
        Set rw = .ListRows.Add.Range '新增一行并获取该行区域
        Set listCols = .ListColumns '获取列表列集合
    End With

    '配置数据源列与归档列的映射
    config = Array("Unit<>A2", "Machine<>B2", "PC<>C2", "Software<>D2", "Who<>E2", "Why<>F2")  

    '循环写入数据
    For Each itm In config
        arr = Split(itm, "<>") '拆分列名和单元格地址
        rw.Cells(listCols(arr(0)).Index).Value = shtForm.Range(arr(1)).Value
    Next itm
    
    '写入当前时间戳到"When"列
    On Error Resume Next '避免列名不存在导致程序崩溃
    rw.Cells(listCols("When").Index).Value = Now() 'Now()返回当前日期+时间，仅需日期用Date()
    On Error GoTo 0
End Sub

方案2：完善Timestamp子过程并在Transfer中调用

如果需要单独复用时间戳逻辑，可以将Timestamp改为带参数的子过程，接收新增行和列集合：

'完善后的Timestamp子过程
Sub Timestamp(rw As Range, listCols As ListColumns)
    On Error Resume Next
    rw.Cells(listCols("When").Index).Value = Now()
    On Error GoTo 0
End Sub

修改Transfer过程，在数据转移完成后调用该子过程：

Sub Transfer()
    Dim config, itm, arr
    Dim rw As Range, listCols As ListColumns
    Dim shtForm As Worksheet
    
    Set shtForm = Worksheets("Interface") '数据源
    
    With Sheets("Archives").ListObjects("table_work")
        Set rw = .ListRows.Add.Range '新增一行并获取该行区域
        Set listCols = .ListColumns '获取列表列集合
    End With

    '配置数据源列与归档列的映射
    config = Array("Unit<>A2", "Machine<>B2", "PC<>C2", "Software<>D2", "Who<>E2", "Why<>F2")  

    '循环写入数据
    For Each itm In config
        arr = Split(itm, "<>") '拆分列名和单元格地址
        rw.Cells(listCols(arr(0)).Index).Value = shtForm.Range(arr(1)).Value
    Next itm
    
    '调用Timestamp写入时间戳
    Timestamp rw, listCols
End Sub

内容的提问来源于stack exchange，提问作者heiavieh