如何通过VBA循环获取每日首个及最后一个门禁记录时间

需求背景 #

我有一份包含多日期的门禁时间列表，需要自动提取每日的首个门禁时间（填充D列）和当日最后一个门禁时间（填充E列）。目前这两列是手动填写的，希望通过VBA实现自动化。

此前我尝试过用Excel函数实现：用LARGE(IF(A1 = A1:A100,ROW(A1:A100)),1)返回当日最大行号，再结合INDEX函数获取对应时间；同理用SMALL函数获取最小行号。现在想知道VBA中是否有类似逻辑或更高效的实现方式。

以下是我编写的不完整代码：

Sub testing2()

Dim dateList As Range

newLR = Sheet3.Cells(Rows.Count, 1).End(xlUp).Row

dateList = Sheet3.Range("a1:a" & newLR).Value

For x = 1 To newLR
    If Sheet3.Cells(x, 1) = dateList Then
        Sheet3.Cells(x, 4) = 3
    End If
Next x

End Sub

解决方案 #

方法1：字典分组法（高效处理大数据集） #

利用字典按日期分组，一次性记录每个日期的首末时间，再批量写入单元格，避免重复查找，效率更高：

Sub GetFirstLastAccessTime()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dateDict As Object
    Dim i As Long
    Dim currentDate As Date
    Dim currentTime As Date
    Dim firstTime As Date
    Dim lastTime As Date
    
    ' 指定目标工作表
    Set ws = Sheet3
    lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
    Set dateDict = CreateObject("Scripting.Dictionary")
    
    ' 遍历数据，按日期分组记录首末时间
    For i = 2 To lastRow ' 假设第1行是表头，从第2行开始遍历数据
        currentDate = Int(ws.Cells(i, "A").Value) ' 提取纯日期部分（去除时间）
        currentTime = ws.Cells(i, "A").Value ' 获取完整的日期时间
        
        If Not dateDict.Exists(currentDate) Then
            ' 首次遇到该日期，初始化首末时间为当前时间
            dateDict(currentDate) = Array(currentTime, currentTime)
        Else
            ' 对比更新最早和最晚时间
            firstTime = dateDict(currentDate)(0)
            lastTime = dateDict(currentDate)(1)
            If currentTime < firstTime Then dateDict(currentDate)(0) = currentTime
            If currentTime > lastTime Then dateDict(currentDate)(1) = currentTime
        End If
    Next i
    
    ' 遍历数据，填充D、E列
    For i = 2 To lastRow
        currentDate = Int(ws.Cells(i, "A").Value)
        ws.Cells(i, "D").Value = dateDict(currentDate)(0) ' 首个门禁时间
        ws.Cells(i, "E").Value = dateDict(currentDate)(1) ' 最后一个门禁时间
    Next i
    
    ' 设置D、E列为日期时间格式
    ws.Range("D:E").NumberFormat = "yyyy/mm/dd hh:mm:ss"
    
    ' 释放对象
    Set dateDict = Nothing
    Set ws = Nothing
End Sub

方法2：模拟Excel函数逻辑（逻辑直观） #

直接在VBA中调用LARGE、SMALL和INDEX函数，和你之前的手动操作逻辑完全一致，代码更简洁：

Sub GetFirstLastWithFunction()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim currentDate As Date
    
    Set ws = Sheet3
    lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To lastRow
        currentDate = Int(ws.Cells(i, "A").Value)
        ' 获取当日最早时间（对应SMALL+INDEX逻辑）
        ws.Cells(i, "D").Value = ws.Evaluate("INDEX(A:A,SMALL(IF(INT(A$2:A$" & lastRow & ")=" & currentDate & ",ROW(A$2:A$" & lastRow & ")),1))")
        ' 获取当日最晚时间（对应LARGE+INDEX逻辑）
        ws.Cells(i, "E").Value = ws.Evaluate("INDEX(A:A,LARGE(IF(INT(A$2:A$" & lastRow & ")=" & currentDate & ",ROW(A$2:A$" & lastRow & ")),1))")
    Next i
    
    ' 设置日期时间格式
    ws.Range("D:E").NumberFormat = "yyyy/mm/dd hh:mm:ss"
    
    Set ws = Nothing
End Sub

注意事项 #

• 若你的数据没有表头，将循环起始行i=2改为i=1即可；
• 方法1适合大数据集，仅需两次遍历；方法2逻辑简单，但大数据集下重复调用函数会降低效率；
• 确保A列数据为日期时间格式，否则需先做格式转换。

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