Excel VBA问题：识别前10%数据并复制行至其他工作表失败

原代码存在的问题 #

• 逻辑偏离需求：原代码仅筛选前2个最大值（For i = 1 To 2），完全没实现"前10%数值"的筛选逻辑
• 拼写错误：xlnon应为xlNone，会导致运行时错误
• 目标位置计算bug：当Sheet2为空时，End(xlUp)会定位到工作表最后一行，粘贴位置直接超出有效范围
• 硬编码范围：固定使用b1:b1000，无法适配实际数据的行数变化
• 复制范围不符：mycell.Resize(1,4)仅复制4列，未满足"复制对应行数据"的需求

修正后的代码 #

Sub CopyTop10PercentRows()
    Dim sourceWs As Worksheet, targetWs As Worksheet
    Dim dataRange As Range
    Dim lastRow As Long, top10Count As Long
    Dim i As Long, targetRow As Long
    
    ' 绑定源表和目标表对象
    Set sourceWs = ThisWorkbook.Worksheets("Sheet1")
    Set targetWs = ThisWorkbook.Worksheets("Sheet2")
    
    ' 清空目标表原有数据（可选，根据实际需求保留或删除）
    targetWs.Cells.Clear
    
    ' 动态获取B列最后一行，确定数据源范围
    lastRow = sourceWs.Cells(sourceWs.Rows.Count, "B").End(xlUp).Row
    Set dataRange = sourceWs.Range("B1:B" & lastRow)
    
    ' 计算前10%的行数（向上取整，避免小数行数）
    top10Count = Application.WorksheetFunction.RoundUp(lastRow * 0.1, 0)
    
    ' 初始化目标表的起始粘贴行
    targetRow = 1
    
    ' 遍历前10%的最大值对应的行
    For i = 1 To top10Count
        Dim maxCell As Range
        ' 找到当前第i大值所在的单元格
        Set maxCell = dataRange.Find(What:=Application.WorksheetFunction.Large(dataRange, i), _
                                    LookIn:=xlValues, LookAt:=xlWhole)
        
        If Not maxCell Is Nothing Then
            ' 高亮源表中符合条件的行
            sourceWs.Rows(maxCell.Row).Interior.ColorIndex = 4
            ' 复制整行到目标表
            sourceWs.Rows(maxCell.Row).Copy Destination:=targetWs.Rows(targetRow)
            targetRow = targetRow + 1
        End If
    Next i
End Sub

关键改进说明 #

1. 动态数据范围：自动识别B列最后一行，无需手动调整范围
2. 正确的前10%计算：用RoundUp确保即使行数乘0.1为小数，也能取到完整的行数
3. 稳定的目标粘贴位置：从第1行开始逐行粘贴，避免空表时的定位错误
4. 完整行复制：直接复制符合条件的整行，满足需求
5. 代码可读性优化：用工作表变量替代重复的Worksheets("Sheet1")写法

额外注意 #

• 如果B列存在重复的最大值，Find只会匹配第一个出现的单元格；若要处理所有重复值，可改为遍历整个数据范围进行判断
• 若不需要清空目标表原有数据，删除targetWs.Cells.Clear即可
• 确保工作簿中存在名为Sheet1和Sheet2的工作表，否则会触发错误

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