按B列分组识别A列新增/删除值：VBA代码适配特定格式求助

问题说明 #

原代码仅全局对比A、B列数值差异，未实现按B列分组，也未区分「最近日期」和「上月」的时间维度，输出结果也不符合字段规整排列的要求。需要修改代码实现：针对每个B列分组，单独对比该分组下A列在最近日期与上月的数值，识别新增（最近有、上月无）和删除（上月有、最近无）的项，并按规整格式输出。

假设数据结构 #

假设你的数据在工作表a中，字段格式如下：

• A列：待对比的数值
• B列：分组标识
• C列：日期（格式示例：2024-05表示上月，2024-06表示最近日期）

修改后的VBA代码 #

Sub CompareByGroupAndDate()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim groupDict As Object
    Dim dateDict As Object
    Dim i As Long
    Dim groupKey As String
    Dim dateKey As String
    Dim lastDate As String
    Dim prevDate As String
    Dim outputRow As Long
    
    ' 初始化工作表和字典
    Set ws = ThisWorkbook.Worksheets("a")
    Set groupDict = CreateObject("Scripting.Dictionary")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    outputRow = 2 ' 结果从第2行开始（假设F1是标题）
    
    ' 1. 按分组+日期收集A列数值
    For i = 2 To lastRow
        groupKey = ws.Cells(i, "B").Value
        dateKey = ws.Cells(i, "C").Value
        
        ' 初始化分组字典
        If Not groupDict.Exists(groupKey) Then
            Set groupDict(groupKey) = CreateObject("Scripting.Dictionary")
        End If
        
        ' 初始化日期对应的数值集合（用字典去重）
        If Not groupDict(groupKey).Exists(dateKey) Then
            Set groupDict(groupKey)(dateKey) = CreateObject("Scripting.Dictionary")
        End If
        groupDict(groupKey)(dateKey)(ws.Cells(i, "A").Value) = True
    Next i
    
    ' 2. 获取所有日期，确定最近日期和上月日期
    Dim allDates As Object
    Set allDates = CreateObject("Scripting.Dictionary")
    For Each groupKey In groupDict.Keys
        For Each dateKey In groupDict(groupKey).Keys
            allDates(dateKey) = True
        Next
    Next
    ' 按日期排序，取最后两个（假设日期是YYYY-MM格式，可直接排序）
    Dim dateArr As Variant
    dateArr = allDates.Keys
    Call QuickSort(dateArr, LBound(dateArr), UBound(dateArr))
    lastDate = dateArr(UBound(dateArr))
    prevDate = dateArr(UBound(dateArr) - 1)
    
    ' 3. 清空结果区域（F、G、H列）
    ws.Range("F:H").ClearContents
    ws.Range("F1:H1").Value = Array("分组", "状态", "数值") ' 设置标题
    
    ' 4. 每个分组单独对比
    For Each groupKey In groupDict.Keys
        ' 新增项：最近日期有，上月无
        If groupDict(groupKey).Exists(lastDate) And groupDict(groupKey).Exists(prevDate) Then
            ' 遍历最近日期的数值
            For Each val In groupDict(groupKey)(lastDate).Keys
                If Not groupDict(groupKey)(prevDate).Exists(val) Then
                    ws.Cells(outputRow, "F").Value = groupKey
                    ws.Cells(outputRow, "G").Value = "新增"
                    ws.Cells(outputRow, "H").Value = val
                    outputRow = outputRow + 1
                End If
            Next val
            
            ' 删除项：上月有，最近日期无
            For Each val In groupDict(groupKey)(prevDate).Keys
                If Not groupDict(groupKey)(lastDate).Exists(val) Then
                    ws.Cells(outputRow, "F").Value = groupKey
                    ws.Cells(outputRow, "G").Value = "删除"
                    ws.Cells(outputRow, "H").Value = val
                    outputRow = outputRow + 1
                End If
            Next val
        End If
    Next groupKey
    
    MsgBox "对比完成，结果已输出至F:H列", vbInformation
End Sub

' 辅助排序函数（针对YYYY-MM格式日期）
Sub QuickSort(arr As Variant, left As Long, right As Long)
    Dim i As Long, j As Long
    Dim pivot As Variant, temp As Variant
    
    i = left
    j = right
    pivot = arr((left + right) \ 2)
    
    Do While i <= j
        Do While arr(i) < pivot And i < right
            i = i + 1
        Loop
        Do While arr(j) > pivot And j > left
            j = j - 1
        Loop
        
        If i <= j Then
            temp = arr(i)
            arr(i) = arr(j)
            arr(j) = temp
            i = i + 1
            j = j - 1
        End If
    Loop
    
    If left < j Then QuickSort arr, left, j
    If i < right Then QuickSort arr, i, right
End Sub

关键改动说明 #

• 分组+日期维度收集数据：使用嵌套字典存储「分组→日期→数值集合」，确保每个分组下的日期数据独立存储。
• 自动识别日期范围：提取所有日期并排序，自动获取最近日期和上月日期（需保证日期为YYYY-MM格式）。
• 规整输出格式：结果按「分组、状态、数值」三列排列，每个分组的新增/删除项清晰对应。
• 去重处理：用字典存储数值自动去重，避免同一分组同一日期下重复数值干扰对比。

使用注意事项 #

1. 确保日期列（C列）格式为YYYY-MM，否则排序逻辑需要调整。
2. 如果你的日期字段不是C列，或者分组/数值列不是B/A列，修改代码中对应列的索引即可。
3. 运行前请备份数据，避免误操作。

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