如何使用Ms. Excel Visual Basic实现特定规则的数据分类？

以下是实现需求的VBA代码，假设源数据位于Sheet1的A1:C列（表头为ID、Position、Item），分组结果将输出到Sheet2：

Sub GroupIDsByPositionItems()
    Dim srcWS As Worksheet, destWS As Worksheet
    Dim idDict As Object, posDict As Object
    Dim allPositions As Collection
    Dim lastRow As Long, i As Long, j As Long
    Dim currentID As String, currentPos As String, currentItem As String
    Dim groups As Collection, group As Collection
    Dim isMatch As Boolean, groupKeyID As String
    
    ' 初始化工作表
    Set srcWS = ThisWorkbook.Sheets("Sheet1")
    Set destWS = ThisWorkbook.Sheets("Sheet2")
    destWS.Cells.Clear
    
    ' 初始化存储结构：idDict存储每个ID对应的Position-Item映射
    Set idDict = CreateObject("Scripting.Dictionary")
    Set allPositions = New Collection
    
    ' 读取源数据
    lastRow = srcWS.Cells(srcWS.Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRow
        currentID = srcWS.Cells(i, "A").Value
        currentPos = srcWS.Cells(i, "B").Value
        currentItem = srcWS.Cells(i, "C").Value
        
        ' 构建ID的Position-Item字典
        If Not idDict.Exists(currentID) Then
            Set idDict(currentID) = CreateObject("Scripting.Dictionary")
        End If
        idDict(currentID)(currentPos) = currentItem
        
        ' 收集所有唯一的Position（去重）
        On Error Resume Next
        allPositions.Add currentPos, Key:=currentPos
        On Error GoTo 0
    Next i
    
    ' 初始化分组集合
    Set groups = New Collection
    
    ' 遍历每个ID进行分组
    For Each currentID In idDict.Keys
        isMatch = False
        ' 检查现有分组是否能加入
        For Each group In groups
            groupKeyID = group(1) ' 取组内第一个ID作为基准
            isMatch = True
            
            ' 遍历所有Position，验证是否匹配
            For Each currentPos In allPositions
                ' 获取基准ID和当前ID的Item值
                Dim baseItem As String, currItem As String
                baseItem = IIf(idDict(groupKeyID).Exists(currentPos), idDict(groupKeyID)(currentPos), "")
                currItem = IIf(idDict(currentID).Exists(currentPos), idDict(currentID)(currentPos), "")
                
                ' 规则：两者都有值则必须相等；否则视为匹配（其中一个或都无值）
                If baseItem <> "" And currItem <> "" And baseItem <> currItem Then
                    isMatch = False
                    Exit For
                End If
            Next currentPos
            
            ' 如果匹配，加入该组
            If isMatch Then
                group.Add currentID
                Exit For
            End If
        Next group
        
        ' 如果没有匹配的分组，新建分组
        If Not isMatch Then
            Set group = New Collection
            group.Add currentID
            groups.Add group
        End If
    Next currentID
    
    ' 输出分组结果到Sheet2
    destWS.Cells(1, "A").Value = "分组结果"
    For i = 1 To groups.Count
        destWS.Cells(i + 1, "A").Value = "Group " & i & ": " & Join(CollectionToArray(groups(i)), ", ")
    Next i
    
    MsgBox "分组完成，结果已输出到Sheet2", vbInformation
End Sub

' 辅助函数：将Collection转换为数组，用于Join输出
Function CollectionToArray(col As Collection) As Variant
    Dim arr() As String
    ReDim arr(1 To col.Count)
    For i = 1 To col.Count
        arr(i) = col(i)
    Next i
    CollectionToArray = arr
End Function

代码说明 #

1. 数据存储：使用Scripting.Dictionary存储每个ID对应的所有Position-Item映射，同时收集所有唯一的Position，确保遍历所有可能的Position进行匹配。
2. 分组逻辑：
   • 以每个组的第一个ID为基准，遍历所有Position验证当前ID是否符合分组规则：
     • 如果基准ID和当前ID在该Position都有Item，则必须值相等；
     • 如果其中一个或两个都没有该Position的Item，视为匹配。
   • 若当前ID能匹配某个现有分组，则加入该组；否则新建分组。
3. 结果输出：将分组转换为字符串格式，输出到Sheet2，同时弹出提示框告知完成。

使用步骤 #

1. 打开Excel，按下Alt + F11打开VBA编辑器；
2. 插入模块（右键点击工程资源管理器中的工作簿名称 → 插入 → 模块）；
3. 将上述代码粘贴到模块中；
4. 修改代码中的工作表名称（如果你的源数据不在Sheet1，或者不想输出到Sheet2）；
5. 运行宏（按下F5，或在Excel界面通过「开发工具」→「宏」选择GroupIDsByPositionItems运行）。

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