VBA每日访问登录宏优化：仅更新指定范围而非重复添加条目

需求说明 #

• 读取「Login Tab」工作表的登录记录，以**证件号（第4列）**作为用户唯一标识
• 若用户未在「Database」工作表中存在：新增完整用户记录，包含基础信息、初始访问数（1）、当前访问日期、登录设备
• 若用户已存在：仅更新以下三个字段：
  • 总访问数（自增1）
  • 最后访问日期（更新为当前时间）
  • 登录设备（追加新设备名称）

原实现代码 #

Sub LogToDatabase()
    Dim loginSheet As Worksheet
    Dim databaseSheet As Worksheet
    Dim lastLoginRow As Long
    Dim lastDatabaseRow As Long
    Dim i As Long

    ' 定义工作表
    Set loginSheet = ThisWorkbook.Sheets("Login Tab")
    Set databaseSheet = ThisWorkbook.Sheets("Database")

    ' 获取登录表最后一行数据行号
    lastLoginRow = loginSheet.Cells(loginSheet.Rows.Count, "A").End(xlUp).Row

    ' 获取数据库表最后一行数据行号
    lastDatabaseRow = databaseSheet.Cells(databaseSheet.Rows.Count, "A").End(xlUp).Row

    ' 遍历登录表中的每条记录
    For i = 2 To lastLoginRow
        ' 检查用户是否已存在于数据库（以第4列证件号为标识）
        If Application.WorksheetFunction.CountIf(databaseSheet.Range("D:D"), loginSheet.Cells(i, 4).Value) = 0 Then
            ' 新增用户记录到数据库
            databaseSheet.Cells(lastDatabaseRow + 1, 1).Value = loginSheet.Cells(i, 1).Value ' 姓名
            databaseSheet.Cells(lastDatabaseRow + 1, 2).Value = loginSheet.Cells(i, 2).Value ' 姓氏
            databaseSheet.Cells(lastDatabaseRow + 1, 3).Value = loginSheet.Cells(i, 3).Value ' 证件类型
            databaseSheet.Cells(lastDatabaseRow + 1, 4).Value = loginSheet.Cells(i, 4).Value ' 证件号
            databaseSheet.Cells(lastDatabaseRow + 1, 5).Value = loginSheet.Cells(i, 5).Value ' 电话
            databaseSheet.Cells(lastDatabaseRow + 1, 6).Value = loginSheet.Cells(i, 6).Value ' 地址
            databaseSheet.Cells(lastDatabaseRow + 1, 7).Value = 1 ' 总访问数
            databaseSheet.Cells(lastDatabaseRow + 1, 8).Value = Now() ' 最后访问日期
            databaseSheet.Cells(lastDatabaseRow + 1, 9).Value = loginSheet.Cells(i, 7).Value ' 登录设备

            lastDatabaseRow = lastDatabaseRow + 1
        Else
            ' 用户已存在，更新相关字段
            Dim existingRow As Long
            existingRow = Application.WorksheetFunction.Match(loginSheet.Cells(i, 4).Value, databaseSheet.Range("D:D"), 0)
            databaseSheet.Cells(existingRow, 7).Value = databaseSheet.Cells(existingRow, 7).Value + 1 ' 总访问数自增1
            databaseSheet.Cells(existingRow, 8).Value = Now() ' 更新最后访问日期为当前时间
            databaseSheet.Cells(existingRow, 9).Value = databaseSheet.Cells(existingRow, 9).Value & ", " & loginSheet.Cells(i, 7).Value ' 追加新设备
        End If
    Next i
End Sub

代码优化建议 #

1. 减少重复查找，提升效率 #

原代码用CountIf和Match两次遍历证件号列，可合并为一次查找，避免重复运算：

Sub LogToDatabase_Optimized()
    Dim loginSheet As Worksheet
    Dim databaseSheet As Worksheet
    Dim lastLoginRow As Long
    Dim lastDatabaseRow As Long
    Dim i As Long
    Dim existingRow As Variant ' 用Variant存储Match结果，支持错误判断

    ' 定义工作表
    Set loginSheet = ThisWorkbook.Sheets("Login Tab")
    Set databaseSheet = ThisWorkbook.Sheets("Database")

    ' 获取登录表最后一行数据行号
    lastLoginRow = loginSheet.Cells(loginSheet.Rows.Count, "A").End(xlUp).Row

    ' 获取数据库表最后一行数据行号
    lastDatabaseRow = databaseSheet.Cells(databaseSheet.Rows.Count, "A").End(xlUp).Row

    ' 遍历登录表中的每条记录
    For i = 2 To lastLoginRow
        ' 一次查找用户是否存在
        existingRow = Application.Match(loginSheet.Cells(i, 4).Value, databaseSheet.Range("D:D"), 0)
        
        If IsError(existingRow) Then
            ' 用户不存在，新增记录
            databaseSheet.Cells(lastDatabaseRow + 1, 1).Value = loginSheet.Cells(i, 1).Value ' 姓名
            databaseSheet.Cells(lastDatabaseRow + 1, 2).Value = loginSheet.Cells(i, 2).Value ' 姓氏
            databaseSheet.Cells(lastDatabaseRow + 1, 3).Value = loginSheet.Cells(i, 3).Value ' 证件类型
            databaseSheet.Cells(lastDatabaseRow + 1, 4).Value = loginSheet.Cells(i, 4).Value ' 证件号
            databaseSheet.Cells(lastDatabaseRow + 1, 5).Value = loginSheet.Cells(i, 5).Value ' 电话
            databaseSheet.Cells(lastDatabaseRow + 1, 6).Value = loginSheet.Cells(i, 6).Value ' 地址
            databaseSheet.Cells(lastDatabaseRow + 1, 7).Value = 1 ' 总访问数
            databaseSheet.Cells(lastDatabaseRow + 1, 8).Value = Now() ' 最后访问日期
            databaseSheet.Cells(lastDatabaseRow + 1, 9).Value = loginSheet.Cells(i, 7).Value ' 登录设备

            lastDatabaseRow = lastDatabaseRow + 1
        Else
            ' 用户已存在，更新相关字段
            databaseSheet.Cells(existingRow, 7).Value = databaseSheet.Cells(existingRow, 7).Value + 1 ' 总访问数自增1
            databaseSheet.Cells(existingRow, 8).Value = Now() ' 更新最后访问日期为当前时间
            ' 检查设备是否已存在，避免重复追加
            If InStr(1, databaseSheet.Cells(existingRow, 9).Value, loginSheet.Cells(i, 7).Value, vbTextCompare) = 0 Then
                databaseSheet.Cells(existingRow, 9).Value = databaseSheet.Cells(existingRow, 9).Value & ", " & loginSheet.Cells(i, 7).Value
            End If
        End If
    Next i
End Sub

2. 避免设备重复记录 #

优化后的代码增加了设备存在性检查，防止同一设备被多次追加到记录中。

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