Excel 获取运行时错误'；1004'；从复制粘贴功能

我试图编写一些代码来识别一行中的值，剪切整行，然后将该行插入第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

错误就在下面这行：

Selection.Insert shift:=xlDown

谢谢

也许

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

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

可能

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行的重叠范围。您试图剪切并粘贴到同一位置，这是不允许的

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行的重叠范围。您试图剪切并粘贴到同一位置，这是不允许的

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

---

这可能就是问题所在

.Rows（lrow）.EntireRow.Cut

这可能是问题所在

.Rows（lrow）.EntireRow.Cut

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