Удаление всех строк без информации в столбцах BG

Question

Я пытаюсь создать программу, которая удаляет все строки без информации в столбцах BG, а затем переставляет данные из вертикальной ориентации в горизонтальную.

Данные представлены только в столбцах AG, расположенных таким образом, что в каждой паре строк (число не является постоянным) появляется ряд дат. Я хочу, чтобы каждая строка с датами вставлялась горизонтально друг от друга, и все данные между датами перемещались в соответствии с их датами (включая столбец A).

Часть, которая удаляет пустые строки, работает хорошо. Однако, когда я пытался написать программу перестановки, я продолжал получать

«Требуется объект»

ошибка, которая появилась в подстроке (AKA первая строка ). Может кто-нибудь помочь мне решить эту проблему? Код вставлен ниже.

Sub MovingDeletion()


Set rngRange = Selection.CurrentRegion
lngNumRows = rngRange.Rows.Count
lngFirstRow = rngRange.Row
lngLastRow = lngFirstRow + lngNumRows - 1

columns("B").Select
lngCompareColumn1 = ActiveCell.Column
columns("C").Select
lngCompareColumn2 = ActiveCell.Column
columns("D").Select
lngCompareColumn3 = ActiveCell.Column
columns("E").Select
lngCompareColumn4 = ActiveCell.Column
columns("F").Select
lngCompareColumn5 = ActiveCell.Column
columns("G").Select
lngCompareColumn6 = ActiveCell.Column

columns("A").Select
lngCompareColumn7 = ActiveCell.Column
Set MedicationRow = 0
'Deletion Code (Works  Fine)
For lngCurrentRow = lngLastRow To lngFirstRow Step -1
Mrow = True
If (Cells(lngCurrentRow, lngCompareColumn1).Text = "" And Cells(lngCurrentRow, lngCompareColumn2).Text = "" And Cells(lngCurrentRow, lngCompareColumn3).Text = "" And Cells(lngCurrentRow, lngCompareColumn4).Text = "" And Cells(lngCurrentRow, lngCompareColumn5).Text = "" And Cells(lngCurrentRow, lngCompareColumn6).Text = "") Then _
Rows(lngCurrentRow).Delete

'Rearrangement Code (Does not  work. Gives Object Requiered error)

Dim counter As Integer
Dim NextRow  As Integer
Dim i As Integer
i = lngCurrentRow
 counter = 0
 Number = 0
 If (Cells(lngCurrentRow, lngCompareColumn7).Text <> "Days") Then
   counter = counter + 1
   If counter > 1 Then
    NextRow = lngCurrentRow - 1
    While (Cells(NextRow, lngCompareColumn7).Text <> "Days")
     NextRow = NextRow - 1
     Number = Number + 1
     Wend
     End If
   Range("A" & CStr(i) & ":G" & CStr(NextRow)).Cut Range("H1" & CStr(i) & ":P" & CStr(NextRow))
  End If

Next lngCurrentRow

End Sub