如何为VBA DAO Recordset项添加书签以分组处理重复记录？

需求说明 #

需要将DAO Recordset中的记录以邮箱地址为唯一标识分组，把同一邮箱的多条记录合并为一条，整合Info字段的内容（去重合并）。

原始数据示例：

Bob Person | Bob@gmail.com | 555-555-5555 | A, B  (需要标记书签)
Tess Jones | TJ@gmail.com  | 555-115-5555 | 1, C  (进入下一轮循环)
Bob Person | Bob@gmail.com | 555-555-5555 | 1, C  (需要标记书签)
Bob Person | Bob@gmail.com | 555-555-5555 | 1, B  (需要标记书签)
Bob Person | Bob@gmail.com | 555-555-5555 | A, B  (需要标记书签)

合并后目标效果：

Bob Person | Bob@gmail.com | 555-555-5555 | 1, A, B, C

问题卡点 #

当前在为符合条件的记录添加书签时遇到困难，不确定是否应该将书签存入数组，附上VBA代码片段：

Dim rst as DAO.recordset
Dim db as DAO.Database
Dim CurrentEmail as String

Dim RecorsetSQL = "SELECT Name, Email, Info Phone FROM TableName"

Set rst = db.OpenRecordSet(RecorsetSQL)
set db = CurrentDB

Do Until rst.EOF
    CurrentEmail = rst!Email
    rst.MoveNext
    
    If CurrentEmail = rst!Email Then
        THIS RECORD = tagged
        'I'd like to bookmark any and all records that meet this criteria as I cycle through them, so that I can manipulate them

Loop

Get all bookmarks where bookmarks = tagged

解决方案思路 #

1. 先调整SQL排序，简化分组遍历 #

首先修改SQL语句，按Email字段排序，让同一邮箱的记录连续排列，避免复杂的书签跳转操作：

Dim RecordsetSQL As String
RecordsetSQL = "SELECT Name, Email, Phone, Info FROM TableName ORDER BY Email"

2. 书签存入数组的可行方案 #

如果必须使用书签，可以将同一邮箱的记录书签存入数组，后续批量处理：

Dim rst As DAO.Recordset
Dim db As DAO.Database
Dim CurrentEmail As String
Dim bookmarkArr() As Variant
Dim arrIndex As Integer
Dim tempInfo As String
Dim infoColl As Collection ' 用于去重存储Info内容

Set db = CurrentDb
Set rst = db.OpenRecordset(RecordsetSQL)
Set infoColl = New Collection

If Not rst.EOF Then
    rst.MoveFirst
    CurrentEmail = rst!Email
    arrIndex = 0
    ReDim bookmarkArr(0)
    
    ' 遍历同一邮箱的所有记录
    Do While Not rst.EOF And rst!Email = CurrentEmail
        ' 添加当前记录书签到数组
        bookmarkArr(arrIndex) = rst.Bookmark
        arrIndex = arrIndex + 1
        ReDim Preserve bookmarkArr(arrIndex)
        
        ' 拆分Info字段并去重收集
        Dim infoParts() As String
        infoParts = Split(rst!Info, ", ")
        Dim part As Variant
        For Each part In infoParts
            On Error Resume Next ' 忽略重复项错误
            infoColl.Add part, Key:=CStr(part)
            On Error GoTo 0
        Next part
        
        rst.MoveNext
    Loop
    
    ' 合并去重后的Info内容
    tempInfo = ""
    For Each part In infoColl
        tempInfo = tempInfo & part & ", "
    Next part
    tempInfo = Left(tempInfo, Len(tempInfo) - 2) ' 移除末尾多余的", "
    
    ' 处理数组中的书签记录（保留第一条，删除其余，更新Info字段）
    rst.Bookmark = bookmarkArr(0)
    rst.Edit
    rst!Info = tempInfo
    rst.Update
    
    ' 删除其余重复记录
    Dim i As Integer
    For i = 1 To UBound(bookmarkArr) - 1
        rst.Bookmark = bookmarkArr(i)
        rst.Delete
    Next i
End If

rst.Close
Set rst = Nothing
Set db = Nothing
Set infoColl = Nothing

3. 无书签的高效方案（推荐） #

不需要使用书签，直接遍历连续的同邮箱记录，处理完后跳过已处理的记录，代码更简洁：

Dim rst As DAO.Recordset
Dim db As DAO.Database
Dim CurrentEmail As String
Dim CurrentName As String
Dim CurrentPhone As String
Dim mergedInfo As String
Dim infoSet As Object

Set db = CurrentDb
Set rst = db.OpenRecordset("SELECT Name, Email, Phone, Info FROM TableName ORDER BY Email")
Set infoSet = CreateObject("Scripting.Dictionary") ' 用字典实现去重

If Not rst.EOF Then
    rst.MoveFirst
    Do Until rst.EOF
        CurrentEmail = rst!Email
        CurrentName = rst!Name
        CurrentPhone = rst!Phone
        infoSet.RemoveAll ' 清空字典
        
        ' 收集当前邮箱所有Info的去重内容
        Do While Not rst.EOF And rst!Email = CurrentEmail
            Dim infoItems() As String
            infoItems = Split(rst!Info, ", ")
            Dim item As Variant
            For Each item In infoItems
                If Not infoSet.Exists(item) Then
                    infoSet.Add item, item
                End If
            Next item
            rst.MoveNext
        Loop
        
        ' 合并Info内容
        mergedInfo = Join(infoSet.Keys, ", ")
        
        ' 插入合并后的记录到新表（建议先存新表验证，再替换原表）
        db.Execute "INSERT INTO MergedTable (Name, Email, Phone, Info) VALUES ('" & _
            Replace(CurrentName, "'", "''") & "', '" & _
            Replace(CurrentEmail, "'", "''") & "', '" & _
            Replace(CurrentPhone, "'", "''") & "', '" & _
            Replace(mergedInfo, "'", "''") & "')"
    Loop
End If

rst.Close
Set rst = Nothing
Set db = Nothing
Set infoSet = Nothing

注意事项 #

• 处理字符串时用Replace转义单引号，避免SQL语法错误
• 建议先将合并结果存入新表，验证正确后再替换原表，防止数据丢失
• 使用字典或集合实现Info字段的去重，确保合并后内容无重复

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