Удалить пустые строки (строки)

Question

У меня проблемы с тем, чтобы этот код работал так, как я хочу.

В настоящее время он удаляет пустые строки, но удаляет пробелы между строками, чего я не хочу, чтобы происходило. Я хочу, чтобы пустые строки между заполненными строками и всем после последней заполненной ячейки в столбце G были удалены. Кто-нибудь может мне помочь. Я добавил картинку, чтобы помочь. Выделенные желтые клетки должны остаться, я хочу удалить линии, выделенные синим цветом.

Public Sub DeleteBlankLines()

' Declaring the variables
Dim WS As Worksheet
Dim UncWs As Worksheet, RepWs As Worksheet, ImpWs As Worksheet
Dim StopAtData As Boolean
Dim UserAnswer As Variant
Dim rngDelete As Range, UncDelete As Range, RepDelete As Range, ImpDelete As Range
Dim RowDeleteCount As Integer

'Set Worksheets
Set UncWs = ThisWorkbook.Sheets("Uncertainty")
Set RepWs = ThisWorkbook.Sheets("Repeatability")
Set WS = ThisWorkbook.Sheets("Datasheet")
Set ImpWs = ThisWorkbook.Sheets("Import Map")

'Set Delete Variables to Nothing
Set rngDelete = Nothing
Set UncDelete = Nothing
Set RepDelete = Nothing
Set ImpDelete = Nothing

RowDeleteCount = 0

'Determine which cells to delete
UserAnswer = MsgBox("Do you want to delete empty rows " & _
"outside of your data?" & vbNewLine, vbYesNoCancel)

If UserAnswer = vbYes Then
    StopAtData = True

    'Not needed Turn off at Call in Form
    'Application.Calculation = xlCalculationManual
    'Application.ScreenUpdating = False
    'Application.EnableEvents = False

    ' Set Range
     DS_LastRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row

    For CurrentRow = DS_StartRow To DS_LastRow Step 1

        ' Delete blank rows by checking the value of cell in column G (Nominal Value)
       With WS.Range("G" & CurrentRow & ":O" & CurrentRow)
            If WorksheetFunction.CountBlank(.Cells) >= 9 Then
               If rngDelete Is Nothing Then
                    Set rngDelete = WS.Rows(CurrentRow)
                    Set UncDelete = UncWs.Rows(CurrentRow)
                    Set RepDelete = RepWs.Rows(CurrentRow)
                    Set ImpDelete = ImpWs.Rows(CurrentRow)
                    RowDeleteCount = 1
               Else
                    Set rngDelete = Union(rngDelete, WS.Rows(CurrentRow))
                    Set UncDelete = Union(UncDelete, UncWs.Rows(CurrentRow))
                    Set RepDelete = Union(RepDelete, RepWs.Rows(CurrentRow))
                    Set ImpDelete = Union(ImpDelete, ImpWs.Rows(CurrentRow))
                    RowDeleteCount = RowDeleteCount + 1
               End If
           End If

        End With
    Next CurrentRow

Else
    Exit Sub

End If

'Refresh UsedRange (if necessary)
If RowDeleteCount > 0 Then
    UserAnswer = MsgBox("This will Delete " & RowDeleteCount & " rows, Do you want to delete empty rows?" & vbNewLine, vbYesNoCancel)

    If UserAnswer = vbYes Then
         ' Delete blank rows
        If Not rngDelete Is Nothing Then
          UncWs.Unprotect ("$1mco")
          RepWs.Unprotect ("$1mco")

          rngDelete.EntireRow.Delete Shift:=xlUp
          UncDelete.EntireRow.Delete Shift:=xlUp
          RepDelete.EntireRow.Delete Shift:=xlUp
          ImpDelete.EntireRow.Delete Shift:=xlUp

          UncWs.Protect "$1mco", , , , , True, True
          RepWs.Protect ("$1mco")

        End If
    Else
        MsgBox "No Rows will be Deleted.", vbInformation, "No Rows Deleted"
    End If
Else
    MsgBox "No blank rows were found!", vbInformation, "No Blanks Found"

End If

' Set New Last Row Moved to Event
DS_LastRow = WS.Range("G7:G" & WS.Rows.Count).End(xlUp).Row


'Not needed Turn on at Call in Form
'Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
'Application.EnableEvents = True

End Sub

Answer 1

Удалить ниже последней строки

Удаляет все данные ниже последней использованной строки в столбце.

Код

'*******************************************************************************
' Purpose:    Deletes all data below the last used row of a specified column.
'*******************************************************************************
Sub DeleteBelowLastRow()

    Const cVntSheet As Variant = "Sheet1"  ' Worksheet Name/Index
    Const cVntColumn As Variant = "G"      ' Last Row Column Letter/Number

    Dim lngLastRow As Long   ' Last Row

    With ThisWorkbook.Worksheets(cVntSheet)
        lngLastRow = .Cells(.Rows.Count, cVntColumn).End(xlUp).Row
        .Range(.Cells(lngLastRow + 1, 1), .Cells(.Rows.Count, 1)) _
                .EntireRow.Delete
    End With

End Sub
'*******************************************************************************

Answer 2

может быть что-то вроде,

dim lr as long

with ThisWorkbook.Sheets("Datasheet")

    lr = .cells.find(what:="*", after:=.cells(1), _
                     LookIn:=xlFormulas, LookAt:=xlPart, _
                     SearchOrder:=xlByRows, SearchDirection:=xlprevious).row 

    .usedrange.offset(lr, 0).entirerow.clear

end with