☰

删除行并将所有行一起移动

tag-icon • tag-icon microsoft-excel
删除行并将所有行一起移动

我需要找出最佳方法和最快的方法来实现删除列中带有 Y 的行A，然后将所有剩余的行向上移动，这样就不会留下空行，如下所示。

Col A    Col B    Col C
Y        TOM      12
O        JOHN     11
Y        FRED     12
         TOM      12
O        JOHN     12
         TOM      12
Y        JOHN     12
Y        TOM      12
Y        JOHN     12
         FRED     10
         JOHN     12

上面是电子表格最初的样子。我希望能够按一两个按钮，让它看起来像这样：

Col A    Col B    Col C
O        JOHN     11
         TOM      12
O        JOHN     12
         TOM      12
         FRED     10
         JOHN     12

这就是我最终需要的样子。

希望有人能帮助我。

致以最诚挚的问候 Natasha Willson

答案1

将以下内容复制到常规 vba 模块中（使用Alt-F11打开 Visual Basic 编辑器）。将代码添加到现有或新的常规模块后，Const根据需要编辑属性。工作表名称是工作表选项卡上显示的名称。要运行代码，请使用Alt- F8，打开宏对话框并双击（运行）Delete_Rows。

警告无法撤消此宏所做的删除，因此撤消缓冲区将被清除。换句话说，这个动作不会出现在-Edit - Undo并且不会产生任何效果。Ctrlz

Option Explicit
Public Sub Delete_Rows()

  ' WARNING: Cannot undo deletions made by this macro and therefore
  '   the Undo Buffer Is Cleared. In other words; this action will
  '   not appear in "Edit - Undo" and Ctrl-z will have no effect.

  ' Delete Rows if row value in value_Column is delete_On_Value.
  ' value_Column must include start_on row number (e.g. A1 or C3)

  ' For speed, only process rows being used <= max_Row.
    Const valueColumn = "A2" ' Beginning Cell (row and column) to consider.
    Const maxRow = "" ' Last row number. If "", rest of rows in use.
    Const deleteOnValue = "Y"
    Const deletionSheetName = "Sheet12"
    Const deleteWarn = True

   '-------------------------------------------------------
   'All code from here on - no more user modifiable setting
   '

    Dim dSht As Worksheet
    Dim resetLastCell As Range
    Dim deleteRange As Range
    Dim r As Range
    Dim rangeStart() As String
    Dim lastRow As String
    Dim tmpEnableEvents As Boolean
    Dim tmpScreenUpdating As Boolean

    On Error Resume Next
    Set dSht = Worksheets(deletionSheetName)
    On Error GoTo 0
    If dSht Is Nothing Then
        MsgBox "Worksheet Named: '" & deletionSheetName & "' not found.", _
            vbExclamation, "Deletion Macro - Error"
        Exit Sub
    End If

    Set resetLastCell = dSht.UsedRange ' call and discard to reset LastCell
    lastRow = dSht.Range(valueColumn).SpecialCells(xlCellTypeLastCell).Row
    If maxRow <> "" Then
       If Val(lastRow) > Val(maxRow) Then lastRow = maxRow
    End If
    rangeStart = Split(dSht.Range(valueColumn).Address(True, False), "$")
    If Val(rangeStart(1)) > Val(lastRow) Then
        If deleteWarn Then
            MsgBox "No used rows beginnig at start row '" & rangeStart(1) _
                & "'.", vbInformation, "Deletion Macro - Exiting"
        End If
        Exit Sub
    End If
    tmpEnableEvents = Application.EnableEvents
    Application.EnableEvents = False
    tmpScreenUpdating = Application.ScreenUpdating
    Application.ScreenUpdating = False

    For Each r In dSht.Range(valueColumn & ":" & rangeStart(0) & lastRow)
        If IsEmpty(r) Then
        ElseIf CStr(r.Value2) = vbNullString Then
        ElseIf r = deleteOnValue Then
            If deleteRange Is Nothing Then
                Set deleteRange = r
            Else
                Set deleteRange = Union(deleteRange, r)
            End If
        End If
    Next r
    If deleteRange Is Nothing Then
        If deleteWarn Then
            MsgBox "No rows to delete.", vbInformation, _
                "Deletion Macro - Exiting"
        End If
    ElseIf deleteWarn Then
        If 1 = MsgBox("Delete " & deleteRange.Count & " row(s) from '" & _
            deletionSheetName & "' tab?", vbQuestion + vbOKCancel, _
            "Deletion Macro - Confirmation") _
        Then
            deleteRange.EntireRow.Delete
        End If
    Else ' no warning - just delete
        deleteRange.EntireRow.Delete
    End If
    Application.ScreenUpdating = tmpScreenUpdating
    Application.EnableEvents = tmpEnableEvents
End Sub

相关内容