利用MS Access VBA统一处理联系人表中同公司的多位置列值

你的原代码核心问题在于：每次发现不同Location时直接拼接内容并跳回记录集开头，导致循环重复处理同一批记录，不断累加内容最终引发字段溢出；同时完全没有实现去重和排序的需求逻辑。

以下是符合需求的正确实现代码：

Private Sub UpdateCompanyLocations()
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim companyDict As Object ' 用字典按公司分组存储唯一郡集合
    Dim locationsColl As Collection
    Dim companyName As String
    Dim locationParts() As String
    Dim part As Variant
    Dim sortedLocations() As String
    Dim i As Integer, j As Integer
    Dim temp As String
    Dim newLocation As String
    
    ' 初始化字典对象
    Set companyDict = CreateObject("Scripting.Dictionary")
    Set db = CurrentDb
    
    ' 第一步：遍历所有记录，收集每个公司的唯一郡名
    Set rst = db.OpenRecordset("SELECT Company, Location FROM Contacts", dbOpenDynaset)
    Do While Not rst.EOF
        companyName = rst!Company
        ' 若字典中无当前公司，创建新集合存储郡名
        If Not companyDict.Exists(companyName) Then
            Set locationsColl = New Collection
            companyDict.Add companyName, locationsColl
        End If
        Set locationsColl = companyDict(companyName)
        
        ' 拆分当前记录的Location字段
        locationParts = Split(rst!Location, ";; ")
        For Each part In locationParts
            ' 利用集合的键实现去重（不区分大小写）
            On Error Resume Next
            locationsColl.Add Trim(part), Key:=UCase(Trim(part))
            On Error GoTo 0
        Next part
        
        rst.MoveNext
    Loop
    rst.Close
    
    ' 第二步：遍历字典，对郡名排序并更新对应公司的所有记录
    Set rst = db.OpenRecordset("SELECT Company, Location FROM Contacts", dbOpenDynaset)
    For Each companyName In companyDict.Keys
        Set locationsColl = companyDict(companyName)
        
        ' 将集合转为数组以便排序
        ReDim sortedLocations(1 To locationsColl.Count)
        For i = 1 To locationsColl.Count
            sortedLocations(i) = locationsColl(i)
        Next i
        
        ' 按字母升序排序（不区分大小写）
        For i = LBound(sortedLocations) To UBound(sortedLocations) - 1
            For j = i + 1 To UBound(sortedLocations)
                If UCase(sortedLocations(i)) > UCase(sortedLocations(j)) Then
                    temp = sortedLocations(i)
                    sortedLocations(i) = sortedLocations(j)
                    sortedLocations(j) = temp
                End If
            Next j
        Next i
        
        ' 拼接成规范格式的Location字符串
        newLocation = Join(sortedLocations, ";; ")
        
        ' 更新该公司的所有记录
        rst.MoveFirst
        Do While Not rst.EOF
            If rst!Company = companyName Then
                rst.Edit
                rst!Location = newLocation
                rst.Update
            End If
            rst.MoveNext
        Loop
    Next companyName
    
    ' 清理对象
    rst.Close
    Set rst = Nothing
    Set db = Nothing
    Set companyDict = Nothing
    
    MsgBox "Location字段更新完成！"
End Sub

代码关键说明 #

1. 分组与去重：用Scripting.Dictionary按公司名称分组，每个公司对应一个Collection，通过集合的键（大写格式）实现不区分大小写的郡名去重。
2. 拆分与收集：拆分每条记录的Location字段，将拆分后的郡名添加到对应公司的集合中，自动过滤重复项。
3. 排序与拼接：将集合转为数组后进行冒泡排序（适合Access场景下的小规模数据），再用;; 拼接成规范格式的字符串。
4. 批量更新：遍历记录集，将同一公司的所有记录Location字段统一更新为合并后的字符串。

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