从复制和粘贴功能中获取运行时错误“1004”答案

【问题标题】：Getting run time error '1004' from copy and paste function从复制和粘贴功能中获取运行时错误“1004”
【发布时间】：2016-01-06 15:38:53
【问题描述】：

我正在尝试编写一些代码来识别一行中的一个值，剪切整行，然后将该行插入到第 2 行（并将行向下移动），但是我收到了运行时错误 1004，说明了一些关于复制和粘贴区域的大小必须相同。任何人都可以帮忙吗？代码如下：

With Sheets("xxx")
    For Lrow = 1 To ActiveSheet.UsedRange.Rows.Count
            With .Cells(Lrow, "J")
                If Not IsError(.Value) Then
                    If .Value = "Desk to adjust" Then
                        .EntireRow.Cut
                        Rows("2:2").Select
                        Selection.Insert shift:=xlDown
                        Selection.NumberFormat = "0"
                    End If
                End If
            End With
    Next Lrow
End With

bug 就在这条线上：

Selection.Insert shift:=xlDown

谢谢！！

【问题讨论】：

这可能是问题所在？ .Rows(lrow).EntireRow.Cut

标签： excel runtime-error with-statement vba

【解决方案1】：

问题在于第 2 行的范围重叠。您试图剪切并粘贴到不允许的同一位置

Sub test()
    With Sheets("xxx")
        For Lrow = 1 To ActiveSheet.UsedRange.Rows.Count
            With .Cells(Lrow, "J")
                If Not IsError(.Value) Then
                    If .Value = "Desk to adjust" Then
                        If Not Lrow = 2 Then
                            .EntireRow.Cut
                            Rows("2:2").Select
                            Selection.Insert shift:=xlDown
                            Selection.NumberFormat = "0"
                        End If
                    End If
                End If
            End With
        Next Lrow
    End With
End Sub

您为什么不尝试一个不那么循环的解决方案。这将为您节省大量时间。

Option Explicit

Sub MoveToTop()

    Dim rData As Range
    Dim rToMove As Range
    Dim i As Long

    Set rData = Sheets("xxx").Cells(1, 1).CurrentRegion

    ' Filter the data in Column J which is field 10
    rData.AutoFilter 10, "Desk to adjust"

    ' Turn off errors in case there is nothing filtered
    ' and cut and paste the data.
    On Error Resume Next
    Set rToMove = rData.Offset(1).Resize(rData.Rows.Count - 1).SpecialCells(xlCellTypeVisible)

    For i = 1 To rToMove.Areas.Count
        rToMove.Areas(i).EntireRow.Cut
        If Application.CutCopyMode = xlCut Then
            Sheets("xxx").Rows(2).Insert xlShiftDown
        End If
    Next i
    On Error GoTo 0

    'Remove the filter
    rData.AutoFilter

End Sub

【讨论】：

【解决方案2】：

也许……

Dim wks           As Worksheet
Dim iRow          As Long

Set wks = Worksheets("xxx")

With wks
  For iRow = 3 To .Cells(.Rows.Count, "J").End(xlUp).Row
    If .Cells(iRow, "J").Value = "Desk to adjust" Then
      .Rows(iRow).Cut
      .Rows(2).Insert
      .Rows(2).NumberFormat = "0"
    End If
  Next iRow
End With

请注意，比较区分大小写。

【讨论】：

另外，您不能将第 2 行剪切到第 2 行；您将通过用户界面收到相同的错误。

【解决方案3】：

Option Explicit

Sub shiftRows()
    Dim lRow As Long
    With Sheets("xxx")
        For lRow = .UsedRange.Row To .UsedRange.Row + .UsedRange.Rows.Count
            With .Cells(lRow, .Columns("J").Column)
                If Not IsError(.Value) Then
                    If .Value = "Desk to adjust" And lRow > 2 Then
                        .EntireRow.Cut
                        .Rows(2).Insert shift:=xlDown
                        .Rows(2).NumberFormat = "0"
                    End If
                End If
            End With
        Next lRow
    End With
End Sub

【讨论】：