excel - 删除空行

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

标签： excelvbadelete-row

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