Получение ошибки времени выполнения «1004» из функции копирования и вставки

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