多工作表指定列提取唯一值并写入新表的VBA问题求助

我来帮你排查代码崩溃的原因，并给出能满足需求的修正方案：

原代码的核心问题 #

• 循环范围过大：直接遍历到Rows.Count（Excel默认有1048576行），哪怕工作表只有几行数据，也会无意义地遍历所有空行，导致程序卡顿甚至崩溃。
• 未过滤空单元格：空值会被错误加入集合，最后得到无效的空条目。
• 错误处理过于宽泛：两次On Error Resume Next会掩盖其他潜在错误（比如工作表访问、数据类型异常等），不利于问题排查。
• 未判断工作表是否有有效数据：如果某个工作表F列没有任何数据，循环会白跑甚至触发错误。
• 未完成写入新工作表的需求：原代码只在调试窗口打印结果，没有实现核心的输出功能。

修正后的完整代码 #

Sub ExtractUniqueExpenses()
    Dim ws As Worksheet
    Dim uniqueExpenses As New Collection
    Dim lastRow As Long
    Dim cellVal As Variant
    Dim outputWs As Worksheet
    Dim outputRow As Long
    
    ' 创建或获取输出用的新工作表
    On Error Resume Next
    Set outputWs = ThisWorkbook.Worksheets("UniqueExpenses")
    If Err.Number <> 0 Then
        Set outputWs = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        outputWs.Name = "UniqueExpenses"
    End If
    On Error GoTo 0
    
    ' 清空输出表已有数据（保留表头）
    outputWs.Range("A2:" & outputWs.Cells(outputWs.Rows.Count, "A").Address).ClearContents
    outputWs.Range("A1").Value = "唯一费用名称"
    outputRow = 2
    
    ' 遍历所有工作表
    For Each ws In ThisWorkbook.Worksheets
        ' 跳过输出表本身，避免重复处理
        If ws.Name <> outputWs.Name Then
            ' 精准获取F列最后一行有数据的行号
            lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
            
            ' 仅当有数据行时才处理
            If lastRow >= 2 Then
                ' 遍历F列的有效数据行
                For i = 2 To lastRow
                    cellVal = ws.Range("F" & i).Value
                    
                    ' 跳过空单元格
                    If cellVal <> "" Then
                        ' 尝试添加到集合，重复值会触发错误，直接跳过
                        On Error Resume Next
                        uniqueExpenses.Add cellVal, Key:=CStr(cellVal)
                        On Error GoTo 0
                    End If
                Next i
            End If
        End If
    Next ws
    
    ' 将唯一值写入输出工作表
    If uniqueExpenses.Count > 0 Then
        For Each cellVal In uniqueExpenses
            outputWs.Range("A" & outputRow).Value = cellVal
            outputRow = outputRow + 1
        Next cellVal
        MsgBox "已成功提取" & uniqueExpenses.Count & "个唯一费用名称到UniqueExpenses工作表！", vbInformation
    Else
        MsgBox "未找到任何有效费用名称！", vbExclamation
    End If
End Sub

代码关键改进说明 #

• 动态定位数据范围：用ws.Cells(ws.Rows.Count, "F").End(xlUp).Row精准找到F列最后一行有数据的位置，避免无效循环。
• 过滤空值：添加If cellVal <> "" Then判断，确保只有有效费用名称才会被加入集合。
• 精准错误处理：仅在添加集合时临时忽略重复值的报错，其他时候关闭错误忽略，方便排查其他问题。
• 自动管理输出表：自动创建/复用UniqueExpenses工作表，清空旧数据保留表头，保证每次运行都是最新结果。
• 跳过输出表：遍历过程中跳过输出表本身，防止重复处理自己的数据。
• 友好反馈：执行完成后弹出提示框，告知提取结果状态。

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