Вырежьте строки и вставьте в одну ячейку выше - ошибка Keep Getting Run Time для областей копирования и вставки не совпадает с перекрытием

Question

У меня есть лист с тысячами строк и несколькими столбцами.Заголовок каждой строки - одна ячейка над цифрами.Например:

My Name     
        2  3 4 5 6

Я хочу вырезать от 2 до 6 и вставить его в последний ряд.

 Sub test2()
Dim rOriginalSelection As Range

    Cells.Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
     End With

    Select Case direction
    Case up
        Set rOriginalSelection = Range("B11:O11" & lrow)
    Case Else
        Debug.Assert False
    End Select

    With rOriginalSelection
        .Select
        .Cut
        Select Case direction
        Case "up"
            .Offset(-1, 0).Select
        End Select
    End With
    Selection.Insert
    rOriginalSelection.Select

Answer 1

Да, вы можете сделать это, используя такой код. Он перемещается по одной строке за раз.

Sub Macro1()

    ' We don't know how long the file is. If we find more than 4 consequent
    ' empty cells in column A, we should stop looping
    Dim EmptyCellCount As Integer

    ' Row number to start from
    Dim MyRow As Integer

    EmptyCellCount = 0
    MyRow = 1

    Do While EmptyCellCount < 5

        ' select A1 and check if there's any content in it
        Range("A" & MyRow).Select

        If Len(Trim(Range("A" & MyRow).Text)) > 0 Then

            ' select content from the next line and put in the current line
            Range("C" & MyRow + 1 & ":Q" & MyRow + 1).Select
            Selection.Cut
            Range("C" & MyRow).Select
            ActiveSheet.Paste

            ' switch to the next row and reset empty cell count
            MyRow = MyRow + 1
            EmptyCellCount = 0

        Else

            ' switch to the next row and increment empty cell count
            MyRow = MyRow + 1
            EmptyCellCount = EmptyCellCount + 1

        End If

    Loop
End Sub

Этот перемещает весь блок на одну строку вверх

Sub Macro2()

    Dim EmptyCellCount As Integer
    Dim MyRow As Integer
    MyRow = 1

    ' Find the cell where the last A cell is filled, approximately
    Do While EmptyCellCount < 3
        If Len(Trim(Range("A" & MyRow).Text)) > 0 Then
            EmptyCellCount = 0
        Else
            EmptyCellCount = EmptyCellCount + 1
        End If
        MyRow = MyRow + 1
    Loop

    ' Move the entire block up one row
    Range("C2:Q" & MyRow).Select
    Selection.Cut
    Range("C1").Select
    ActiveSheet.Paste

End Sub