VBA代码第二循环无法运行求助：需转移10%最高行数据至其他工作表

你的代码存在几处核心问题，既未匹配「提取前10%行」的需求，也导致转移循环失效，具体问题和修正方案如下：

1. 核心逻辑偏差与语法错误 #

• 你当前用Large(myrange, i)遍历整个A1:B7区域的前2个最大值，但需求是按行的指定指标列筛选前10%，而非整个区域的极值。
• xlnon是拼写错误，正确写法为xlNone，该错误会导致无法清除原有单元格格式，干扰后续颜色标记判断。

2. 转移循环的失效原因 #

• TransIDField范围定义缺陷：Range("A2").End(xlDown)若A列存在空值，会提前终止范围选取，导致部分数据未被遍历。
• 复制目标单元格定位错误：当Sheet2为空时，HTransWS.Range("A1").Offset(HTransWS.Rows.Count - 1, 0).End(xlUp).Offset(1, 0)会定位到A2，而非A1，造成首行空行。
• 颜色标记与转移判断不匹配：你给整个A1:B7区域的单元格标色，但转移时仅检查A列单元格颜色，会漏判A列未标色但其他列符合条件的行。

修正后的完整代码（高效实现版） #

Sub CopyTop10PercentRows()
    Dim sourceWS As Worksheet, targetWS As Worksheet
    Dim dataRange As Range
    Dim lastRow As Long, top10PercentCount As Long
    
    ' 绑定工作表
    Set sourceWS = ThisWorkbook.Worksheets("sheet1")
    Set targetWS = ThisWorkbook.Worksheets("sheet2")
    
    ' 获取数据最后一行（假设指标列为A列，可按需修改）
    lastRow = sourceWS.Cells(sourceWS.Rows.Count, "A").End(xlUp).Row
    ' 定义完整数据范围（假设数据覆盖A-J列，可调整列数）
    Set dataRange = sourceWS.Range("A2:J" & lastRow)
    
    ' 计算前10%的行数（向上取整，避免小数行数）
    top10PercentCount = Application.WorksheetFunction.RoundUp((lastRow - 1) * 0.1, 0)
    
    ' 清空目标表原有数据（可选，根据需求保留）
    targetWS.Cells.Clear
    
    ' 按指标列降序排序，直接提取前N行（比标色循环更高效）
    sourceWS.Sort.SortFields.Clear
    sourceWS.Sort.SortFields.Add2 Key:=sourceWS.Range("A2:A" & lastRow), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With sourceWS.Sort
        .SetRange dataRange
        .Header = xlNo ' 若表头存在，改为xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
    
    ' 复制前10%行到目标表
    dataRange.Resize(top10PercentCount).Copy Destination:=targetWS.Range("A1")
    
    ' 自动调整目标表列宽
    targetWS.Columns.AutoFit
End Sub

若需保留「标色后转移」的逻辑，可参考以下调整 #

1. 先计算指标列的90百分位数（筛选阈值）：

   Dim p90 As Double
   p90 = Application.WorksheetFunction.Percentile(sourceWS.Range("A2:A" & lastRow), 0.9)
   

2. 循环每行判断并标记：

   Dim row As Range
   For Each row In dataRange.Rows
       If row.Cells(1, 1).Value >= p90 Then ' 假设第1列为指标列
           row.Interior.ColorIndex = 4
           row.Copy Destination:=targetWS.Range("A" & targetWS.Cells(targetWS.Rows.Count, "A").End(xlUp).Row + 1)
       End If
   Next row
   

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