Excel VBA动态单元格区域保留与标准化表格提取需求

原代码存在的问题 #

• 变量cl未初始化，直接判断会触发运行时错误
• 仅针对单个单元格处理，未遍历所有字体颜色为3（红色）的单元格
• 未实现「保留目标区域、剔除无关内容」的核心逻辑

替代实现思路 #

更安全的方式是收集所有目标区域并复制到新工作表（避免直接修改原表导致数据丢失），核心步骤：

1. 遍历当前工作表中所有红色字体的单元格
2. 收集每个单元格对应的CurrentRegion，并自动去重（避免重复处理同一索引区域）
3. 将所有目标区域依次复制到新建的标准化表格工作表中

完整VBA代码 #

Sub ExtractRedRegionsToNewSheet()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim redCell As Range
    Dim targetRegion As Range
    Dim allRegions As Collection
    Dim rng As Variant
    Dim lastRow As Long
    
    ' 初始化源工作表（当前激活的工作表）
    Set wsSource = ActiveSheet
    ' 创建新工作表存放标准化结果
    Set wsTarget = ThisWorkbook.Sheets.Add(After:=wsSource)
    wsTarget.Name = "标准化索引表"
    
    ' 用集合存储目标区域，实现自动去重
    Set allRegions = New Collection
    
    ' 遍历所有带常量值且字体为红色的单元格
    On Error Resume Next ' 忽略无匹配单元格的错误
    For Each redCell In wsSource.Cells.SpecialCells(xlCellTypeConstants, xlTextValues + xlNumbers)
        If redCell.Font.Color = 3 Then
            Set targetRegion = redCell.CurrentRegion
            ' 以区域地址为唯一标识，重复区域会触发错误并自动跳过
            allRegions.Add targetRegion, Key:=CStr(targetRegion.Address)
        End If
    Next redCell
    On Error GoTo 0
    
    ' 将收集到的区域复制到目标工作表
    lastRow = 1
    For Each rng In allRegions
        rng.Copy wsTarget.Cells(lastRow, 1)
        ' 不同类别区域间留空行分隔
        lastRow = wsTarget.Cells(wsTarget.Rows.Count, 1).End(xlUp).Row + 2
    Next rng
    
    MsgBox "提取完成，结果已保存至工作表：" & wsTarget.Name, vbInformation
End Sub

关键细节说明 #

• 用Collection的Key特性自动去重，避免重复提取同一索引区域
• 采用复制到新表的逻辑，完全保留原数据的完整性
• 自动在不同类别区域间添加空行，提升标准化表格的可读性

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