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

Question

Мне нужно, чтобы этот код смотрел снизу вверх, и как только он достигает ячейки в заполненном столбце G, он прекращает удаление строк. Кто-нибудь может мне помочь. В столбце G будут пробелы, но мне просто нужно посмотреть снизу вверх до последней заполненной ячейки в столбце 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("A" & WS.Rows.Count).End(xlUp).Row

    'Update Line Count on Datasheet
    WS.Range("A9").Value = DS_LastRow - DS_StartRow + 1


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



End Sub

Answer 1

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

Вместо Delete вы можете использовать Clear, или, если вы хотите сохранить форматирование ниже последней строки, вы можете использовать ClearContents.

Код

Option Explicit

Sub DelRows()

    Const cSheet As Variant = "Sheet1"  ' Worksheet Name/Index
    Const cColumn As Variant = "G"      ' Cirteria Column Letter/Number

    Dim lastR As Long   ' Last Row

    With ThisWorkbook.Worksheets(cSheet)
        lastR = .Cells(.Rows.Count, cColumn).End(xlUp).Row
        .Range(.Cells(lastR + 1, 1), .Cells(.Rows.Count, 1)).EntireRow.Delete
    End With

End Sub