Excel VBA宏执行报错：将指定行复制到黑色单元格下方失败

需求说明 #

• 将指定工作表中的目标行复制到Sheet1中手动设置为黑色的单元格下方
• 若Sheet1中未检测到黑色单元格，则将目标行复制到Sheet1的顶部

原代码及错误信息 #

自行编写的VBA代码 #

Sub copytherows(clf As Long, lastcell As Long) 'clf - cell that marks the start, lastcell - ending cell
   
    Dim st As Long, cnext As Range
    Dim wshet As Worksheet
    Dim wshetend As Worksheet
    'st - start of looking up, cnext - range of lines, wshet - worksheet
Dim coprange As String
Dim cnextcoprow, cnextrow As Long
'variables for copying macro part
Dim rangehelper As Range
Dim TargetColor As Long
Dim cell As Range
Dim sht As Worksheet
Dim x As Long
Dim Aend As Long
    Set wshet = Worksheets(1)
    Set wshetend = Sheets("Sheet1")
    wshetend.Cells.Delete
    
    For st = 1 To wshet.Cells(Rows.Count, "B").End(xlUp).Row
        If wshet.Cells(st, "B").Interior.Color = clf Then 'has the color of interest
             cnextcoprow = st
            Set cnext = wshet.Cells(st, "B").Offset(1, 0)            'next cell down
            
            Do While cnext.Interior.Color <> lastcell
                Set cnext = cnext.Offset(1, 0) 'next row
            Loop
            st = st + 1
            
        End If
    Next st
  cnextrow = cnext.Row - 1
  
    coprange = cnextcoprow & ":" & cnextrow

Aend = Cells(Rows.Count, "A").End(xlUp).Row
'set color is black
  TargetColor = RGB(255, 255, 255)


wshetend.Activate

  For x = 1 To Rows.Count
    If wshetend.Cells(x, "A").Interior.Color = TargetColor Then

      
      x = x + 1
       Set rangehelper = wshetend.Rows(x)
      wshet.Range(coprange).Copy wshetend.Range(rangehelper).Offset(1)
     
 Else
 wshet.Range(coprange).Copy wshetend.Range("A" & Rows.Count).End(xlUp).Offset(1)
 End If
 Next x
End Sub

错误信息 #

运行时错误'1004'：对象'_Worksheet'的方法'Range'失败，错误行代码：

wshet.Range(coprange).Copy wshetend.Range(rangehelper).Offset(1)

补充说明 #

• 确认工作簿中存在Sheet1
• 当前工作表（wshet）状态如图1所示，若选择section1和section3，section3应放置在目标工作表中section1的黑色单元格位置，最终效果如图2所示

问题分析与修复 #

核心错误原因 #

1. Range对象调用错误：rangehelper已经是wshetend.Rows(x)返回的Range对象，无需再用wshetend.Range()包裹，直接使用rangehelper.Offset(1)即可，否则会触发1004错误。
2. 颜色值设置错误：RGB(255,255,255)是白色，黑色的RGB值应为RGB(0,0,0)。
3. 循环逻辑缺陷：遍历所有行效率极低，且找到黑色单元格后会继续执行Else分支，导致重复复制；原代码仅能获取最后一个目标section的范围，无法处理多个section的复制需求。
4. 不必要的Activate操作：激活工作表容易引发不稳定问题，直接通过工作表对象操作更可靠。

修正后的完整代码 #

Sub copytherows(clf As Long, lastcell As Long)
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim startRow As Long, endRow As Long
    Dim targetRow As Long
    Dim targetColor As Long
    Dim cell As Range
    Dim copyRanges As Collection
    Dim copyRange As Range
    
    '初始化工作表对象
    Set wsSource = Worksheets(1)
    Set wsTarget = Sheets("Sheet1")
    Set copyRanges = New Collection
    
    '清空目标工作表
    wsTarget.Cells.Delete
    
    '获取所有需要复制的section范围
    startRow = 1
    Do While startRow <= wsSource.Cells(Rows.Count, "B").End(xlUp).Row
        If wsSource.Cells(startRow, "B").Interior.Color = clf Then
            '找到当前section的结束行
            endRow = startRow + 1
            Do While endRow <= wsSource.Cells(Rows.Count, "B").End(xlUp).Row And _
                  wsSource.Cells(endRow, "B").Interior.Color <> lastcell
                endRow = endRow + 1
            Loop
            endRow = endRow - 1
            '将当前section范围加入集合
            copyRanges.Add wsSource.Rows(startRow & ":" & endRow)
            '跳过已处理的行
            startRow = endRow + 1
        Else
            startRow = startRow + 1
        End If
    Loop
    
    '设置目标颜色为黑色
    targetColor = RGB(0, 0, 0)
    
    '查找目标工作表中第一个黑色单元格的行
    targetRow = 0
    For Each cell In wsTarget.Columns("A").Cells
        If cell.Interior.Color = targetColor Then
            targetRow = cell.Row + 1 '复制到黑色单元格下方
            Exit For
        End If
        '如果遍历到空行，说明没有黑色单元格，退出循环
        If cell.Value = "" And cell.Row > wsTarget.Cells(Rows.Count, "A").End(xlUp).Row Then
            Exit For
        End If
    Next cell
    
    '如果未找到黑色单元格，复制到顶部
    If targetRow = 0 Then targetRow = 1
    
    '批量复制所有section
    For Each copyRange In copyRanges
        copyRange.Copy wsTarget.Cells(targetRow, 1)
        targetRow = targetRow + copyRange.Rows.Count
    Next copyRange
End Sub

关键修改点 #

• 改用Collection存储所有需要复制的section范围，支持多section复制
• 修正黑色RGB值为RGB(0,0,0)
• 移除Activate操作，直接通过工作表对象操作
• 优化目标行查找逻辑，仅遍历到有效行末尾，提升效率
• 修复Range对象调用错误，避免1004运行时错误

内容的提问来源于stack exchange，提问作者Marcin Jędrzejczyk