VBA如何为Excel各部门创建无重复集合并添加对应账号

核心采用字典对象存储部门与对应账号集合的映射关系，利用字典键的唯一性规避重复创建Collection的问题，遍历一次数据即可完成所有集合的生成，适配你当前的数据量级效率足够。

• 首先创建字典对象，推荐用后期绑定的方式，不需要提前配置引用，兼容性更好
• 遍历所有数据行，对每一行的部门字段做存在性判断：
  • 若当前部门不在字典的键列表中：新建一个Collection，将当前行账号加入集合后，以部门名为键、集合为值存入字典
  • 若当前部门已存在于字典的键列表中：直接将当前行账号追加到该部门对应的Collection中
• 遍历完成后，字典内所有值就是各部门对应的账号集合，直接通过部门名即可调取对应集合

Sub 按部门生成账号集合()
    Dim deptDict As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim currentDept As String
    Dim currentAccount As Long
    
    ' 初始化字典（后期绑定，无需提前引用）
    Set deptDict = CreateObject("Scripting.Dictionary")
    ' 绑定数据所在工作表，可按需修改表名
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ' 获取A列最后一行数据的行号
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历数据行，默认第1行为表头，数据从第2行开始，可按需调整起始行
    For i = 2 To lastRow
        currentDept = Trim(ws.Cells(i, "B").Value)
        currentAccount = ws.Cells(i, "A").Value
        
        ' 部门不存在则新建对应集合
        If Not deptDict.Exists(currentDept) Then
            Dim newCol As Collection
            Set newCol = New Collection
            newCol.Add currentAccount
            deptDict.Add Key:=currentDept, Item:=newCol
        Else
            ' 部门已存在则追加账号
            deptDict(currentDept).Add currentAccount
        End If
    Next i
    
    ' 后续使用示例：输出AP部门的账号数量
    ' MsgBox "AP部门账号数：" & deptDict("AP").Count
End Sub

• 如果运行报错，可尝试在VBA编辑器的「工具-引用」中勾选「Microsoft Scripting Runtime」，然后将字典声明修改为Dim deptDict As New Dictionary即可
• 代码默认数据从第2行开始，如果你的表格无表头或者表头行数不同，自行调整For循环的起始i值即可
• 生成的所有集合都存储在deptDict对象中，不需要额外声明11个部门对应的独立集合变量，直接通过deptDict("部门名称")即可调取对应账号集合

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