VBA提取非空单元格值至另一工作表列去重时无限循环如何解决

原代码出现无限循环、运行异常的核心原因如下：

• 未声明、未赋值wb工作簿对象，直接调用会触发对象引用错误，未开启强制变量声明时会出现逻辑混乱
• For Each循环语法错误，原写法For Each c Lng rng不符合VBA语法规范，无法正确遍历目标范围
• 目标表写入逻辑有缺陷：目标表全空时.End(xlUp)会定位到第1行，偏移2行写入会跳过首行；逐单元格调用CountIf去重效率极低，数据量稍大就会卡顿假死，表现和无限循环一致
• 原逻辑仅处理单个工作表的A列，不满足「遍历所有工作表、提取全部非空单元格」的需求

Sub 提取全表不重复值()
    Dim wb As Workbook
    Dim sourceWs As Worksheet, targetWs As Worksheet
    Dim allNonEmptyRng As Range, cell As Range
    Dim uniqueDict As Object
    
    ' 初始化绑定对象
    Set wb = ThisWorkbook
    Set uniqueDict = CreateObject("Scripting.Dictionary")
    uniqueDict.CompareMode = vbTextCompare ' 文本匹配不区分大小写
    
    ' 初始化结果表，不存在则自动新建
    On Error Resume Next
    Set targetWs = wb.Worksheets("提取结果")
    On Error GoTo 0
    If targetWs Is Nothing Then
        Set targetWs = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
        targetWs.Name = "提取结果"
    End If
    targetWs.UsedRange.ClearContents ' 清空旧结果
    
    ' 遍历所有工作表，跳过结果表自身
    For Each sourceWs In wb.Worksheets
        If sourceWs.Name <> targetWs.Name Then
            ' 定位当前表所有非空常量单元格，自动跳过空单元格，兼容空行空列间隔场景
            Set allNonEmptyRng = Nothing
            On Error Resume Next
            Set allNonEmptyRng = sourceWs.UsedRange.SpecialCells(xlCellTypeConstants, xlNumbers + xlTextValues + xlLogical)
            On Error GoTo 0
            
            ' 非空值存入字典自动去重
            If Not allNonEmptyRng Is Nothing Then
                For Each cell In allNonEmptyRng
                    If Not uniqueDict.Exists(CStr(cell.Value)) Then
                        uniqueDict.Add CStr(cell.Value), cell.Value
                    End If
                Next
            End If
        End If
    Next
    
    ' 一次性批量写入所有不重复值到结果表A列
    If uniqueDict.Count > 0 Then
        targetWs.Range("A1").Resize(uniqueDict.Count, 1).Value = Application.Transpose(uniqueDict.Items)
    End If
    
    ' 释放对象
    Set uniqueDict = Nothing
    Set allNonEmptyRng = Nothing
    Set targetWs = Nothing
    Set wb = Nothing
    MsgBox "提取完成，共获取不重复值" & uniqueDict.Count & "个", vbInformation
End Sub

• 用字典对象做去重判断，相比逐行调用CountIf函数性能提升数十倍，不会出现大数据量下卡顿假死的类无限循环问题
• 自动遍历工作簿内所有工作表，自动识别每个工作表的所有非空单元格，无需手动指定行号列号，完全兼容非空单元格之间存在空行、空列的场景
• 结果表不存在时自动创建，每次运行自动清空历史数据，避免重复写入
• 采用批量写入方式输出结果，避免逐单元格写入触发的屏幕重绘、公式重算带来的性能损耗
• 自动跳过错误值、空值，不会将无效内容写入结果列

若仅需要提取指定列的内容，可将范围定位部分的sourceWs.UsedRange替换为目标列范围即可，例如仅提取所有表A列时，替换为sourceWs.Range("A1:A" & sourceWs.Cells(sourceWs.Rows.Count,1).End(xlUp).Row)

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