Question

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

谢谢！

Answer 1

也许......

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

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

Answer 2

问题是第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

Answer 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

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

3 个答案: