带条件筛选可见行并按百分比计算后复制的VBA代码问题

原代码核心问题 #

1. 条件值来源错误：注释说明条件来自目标工作表（Sheet5）B2，但代码实际从源表DB2的B2取值，导致筛选逻辑完全偏离预期。
2. 冗余列循环：复制1-10列时循环执行10次全范围复制，既低效又可能引发数据覆盖问题。
3. 可见行判断低效：逐行检查行是否可见的方式在筛选后不仅慢，还不如直接获取可见行范围可靠。

修复后的代码 #

Sub VisibleRowsAndMultiplyByPercentage()
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim wsCriteria As Worksheet ' 存储筛选条件的工作表
    Dim lastRowDest As Long
    Dim criteria As Variant
    Dim visibleRows As Range
    Dim currentRow As Range
    Dim j As Long
    
    ' 初始化工作表对象
    Set wsSource = ThisWorkbook.Sheets("DB2")
    Set wsDestination = ThisWorkbook.Sheets("DB3")
    Set wsCriteria = ThisWorkbook.Sheets("Sheet5") ' 按注释要求的条件来源
    
    ' 获取筛选条件值
    criteria = wsCriteria.Range("B2").Value
    If IsEmpty(criteria) Then
        MsgBox "条件单元格B2为空，请输入筛选条件！", vbExclamation
        Exit Sub
    End If
    
    ' 查找目标工作表最后一行（A列）
    lastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row + 1
    
    ' 获取源表中A列区域的可见行（排除前两行表头）
    On Error Resume Next ' 处理无匹配行的情况
    Set visibleRows = wsSource.Range("A3:A" & wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row) _
        .SpecialCells(xlCellTypeVisible) _
        .EntireRow
    On Error GoTo 0
    
    If visibleRows Is Nothing Then
        MsgBox "未找到符合条件的可见行！", vbInformation
        Exit Sub
    End If
    
    ' 遍历每一行可见行
    For Each currentRow In visibleRows
        ' 检查当前行A列是否匹配条件
        If currentRow.Cells(1).Value = criteria Then
            ' 一次性复制1-10列的值
            wsDestination.Cells(lastRowDest, 1).Resize(, 10).Value = currentRow.Cells(1).Resize(, 10).Value
            
            ' 处理11-22列的百分比计算
            For j = 11 To 22
                ' 跳过空值或非数值单元格，避免运行错误
                If IsNumeric(currentRow.Cells(j).Value) And IsNumeric(wsSource.Cells(1, j).Value) Then
                    wsDestination.Cells(lastRowDest, j).Value = currentRow.Cells(j).Value * wsSource.Cells(1, j).Value
                Else
                    wsDestination.Cells(lastRowDest, j).Value = "" ' 非数值则留空
                End If
            Next j
            
            ' 目标行下移
            lastRowDest = lastRowDest + 1
        End If
    Next currentRow
    
    MsgBox "数据处理完成！", vbInformation
End Sub

关键优化点 #

• 修正条件来源：改为从Sheet5的B2获取筛选条件，符合需求逻辑。
• 直接获取可见行：使用SpecialCells(xlCellTypeVisible)快速定位筛选后的可见行，避免逐行检查的低效操作。
• 移除冗余循环：一次性复制1-10列，大幅提升执行效率。
• 增加错误处理：添加空条件检查、无匹配行提示，以及数值有效性判断，避免运行时崩溃。
• 代码结构清晰：新增wsCriteria变量明确条件来源工作表，逻辑更易读。

使用说明 #

1. 确保Sheet5的B2单元格已输入正确的筛选条件。
2. 确认DB2工作表已应用所需的筛选规则（如果需要）。
3. 运行宏后，符合条件的可见行将按要求复制到DB3的最后一行。

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