I am having trouble getting this code to work the way I want it to.

It currently deletes blank lines, but is deleting the blanks in between lines, which I do not want to happen. I want the blank lines in between the populated rows and everything after the last populated cell in Column G to be deleted. Can some one help me. I have added a picture to help. The highlighted yellow cells need to remain, I want to delete the lines colored blue.

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

maybe something like,

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

Delete Below Last Row

Deletes all data below the last used row in a column.

The Code

'*******************************************************************************

' 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

'*******************************************************************************