Excel中UNIQUE函数溢出时自动增删行的VBA代码排查求助

原代码存在的核心问题 #

• 事件触发逻辑错误：Worksheet_Change仅在手动修改单元格内容时触发，但UNIQUE函数的溢出结果变化（比如源数据更新导致唯一值数量增减）不会触发这个事件，必须换成Worksheet_Calculate事件才能监控公式结果的动态变化。
• 溢出错误时数组调用报错：当UNIQUE函数因下方有数据出现#SPILL!错误时，myCell.CurrentArray会直接抛出运行时错误——错误单元格不存在CurrentArray对象，必须先判断单元格状态，再计算实际需要的输出行数。
• 行插入逻辑完全颠倒：原代码判断lastRow + numRows > Me.Rows.Count才插入行，逻辑完全错误。正确逻辑应该是：当UNIQUE需要的输出行数超过公式单元格下方的可用空行数时，插入缺失的行，且原代码的插入行数计算完全错误，未考虑公式本身的行位置。
• 行删除逻辑无效：原代码的循环范围和判断条件无法正确删除UNIQUE结果减少后多余的空行，甚至可能误删有用数据。

修正后的代码 #

Private Sub Worksheet_Calculate()
    Dim ws As Worksheet
    Dim cell As Range
    Dim spillRange As Range
    Dim requiredRows As Long
    Dim currentAvailableRows As Long
    Dim lastRowInCol As Long
    Dim i As Long
    
    Set ws = Me
    '遍历所有包含UNIQUE函数的单元格
    For Each cell In ws.UsedRange
        If InStr(cell.Formula, "=UNIQUE(") > 0 Then
            On Error Resume Next
            Set spillRange = cell.SpillingToRange
            On Error GoTo 0
            
            '处理溢出错误的情况
            If cell.Value = "#SPILL!" Then
                '计算UNIQUE实际需要的输出行数
                requiredRows = Evaluate("ROWS(" & Mid(cell.Formula, 9, Len(cell.Formula) - 9) & ")")
                lastRowInCol = ws.Cells(ws.Rows.Count, cell.Column).End(xlUp).Row
                '计算公式下方已占用的行数
                currentAvailableRows = lastRowInCol - cell.Row
                
                '插入缺失的行，给UNIQUE腾出空间
                If requiredRows > currentAvailableRows Then
                    ws.Rows(cell.Row + 1 & ":" & cell.Row + (requiredRows - currentAvailableRows)).Insert Shift:=xlDown
                End If
            ElseIf Not spillRange Is Nothing Then
                '处理溢出结果正常的情况，删除结果区域下方的多余空行
                lastRowInCol = ws.Cells(ws.Rows.Count, cell.Column).End(xlUp).Row
                '倒序删除空行，避免行号错乱
                For i = lastRowInCol To spillRange.Row + spillRange.Rows.Count Step -1
                    If Application.CountA(ws.Rows(i)) = 0 Then
                        ws.Rows(i).Delete Shift:=xlUp
                    End If
                Next i
            End If
        End If
    Next cell
End Sub

修正说明 #

1. 替换为Worksheet_Calculate事件，只要工作表公式计算就会触发，能实时监控UNIQUE结果的变化。
2. 用SpillingToRange获取正常溢出区域，针对#SPILL!错误，通过Evaluate计算UNIQUE实际需要的输出行数。
3. 重新计算插入行数：对比UNIQUE需要的行数和公式下方的可用空间，精准插入缺失的行。
4. 倒序删除溢出区域下方的空行，避免删除过程中行号错乱，同时判断整行是否为空，防止误删有用数据。

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