如何简化VBA筛选复制重复代码？实现简洁的筛选复制例程

当然可以！你这段代码里重复的筛选→复制逻辑完全可以通过循环+条件-目标映射来大幅简化，既减少冗余代码，后续维护（比如新增/修改筛选条件）也会更高效。

优化后的完整代码 #

Sub FilterandTrans()
    Dim LastRow As Long
    Dim criteriaMap As Variant
    Dim i As Integer
    
    ' 定义筛选条件和对应目标列的映射数组
    ' 格式：{筛选条件, 目标列地址}
    criteriaMap = Array( _
        Array("Alpha", "a2"), _
        Array("Beta", "b2"), _
        Array("Delta", "c2"), _
        Array("Gamma", "d2"), _
        Array("Rho", "e2") _
    )
    
    With Worksheets("Sheet1")
        ' 替换"inf"为0的操作保留
        .Range("N:N").Replace What:="inf", Replacement:="0", LookAt:=xlPart, _
            SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
            
        LastRow = .Range("M" & .Rows.Count).End(xlUp).Row
        
        ' 开启自动筛选（如果还没开启）
        If Not .AutoFilterMode Then .Range("$M:$M").AutoFilter
        
        ' 循环处理每个筛选条件
        For i = LBound(criteriaMap) To UBound(criteriaMap)
            ' 应用当前筛选条件
            .Range("$M:$M").AutoFilter Field:=1, Criteria1:=criteriaMap(i)(0)
            
            On Error Resume Next ' 处理无匹配单元格的情况
            ' 复制可见单元格到目标位置
            .Range("N2:N" & LastRow).SpecialCells(xlCellTypeVisible).Copy _
                Destination:=ThisWorkbook.Sheets(2).Range(criteriaMap(i)(1))
            On Error GoTo 0 ' 恢复错误处理
        Next i
        
        ' 关闭自动筛选
        .AutoFilterMode = False
    End With
End Sub

关键优化点说明 #

• 条件映射数组：把所有筛选条件和对应的目标列地址放在一个二维数组里，以后要加新条件，只需在数组里新增一行Array("新条件", "目标列")即可，不用重复写筛选复制的代码。
• 循环处理：通过For循环遍历映射数组，自动完成每个条件的筛选和复制操作，彻底消除重复代码。
• 错误处理：加入On Error Resume Next避免当某个筛选条件没有匹配单元格时，代码报错中断（SpecialCells(xlCellTypeVisible)在无可见单元格时会抛出错误）。
• 简化筛选开关：先判断自动筛选是否已开启，避免重复执行.Range("$M:$M").AutoFilter。

这样修改后，代码的可读性和可维护性都提升了不少，逻辑也更清晰。

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