Jtdylktuy

I am needing to work out best way and quickest way to be able to achieve Deleting rows with an Y in column A and then moving all remaining rows up so no blank lines are left, as illustrated below.

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

Above is what the spread sheet looks like at first. I wish to be able to press a button or two and have it look like this:

Col A    Col B    Col C

O        JOHN     11

         TOM      12

O        JOHN     12

         TOM      12

         FRED     10

         JOHN     12

This is how I need it to look at end.

Hoping someone can help me out.

Kindest Regards
Natasha Willson

Copy the following into a regular vba Module (Use Alt-F11 to open the Visual Basic editor). After adding the code to an existing or new regular module, edit the Const properties as needed. The sheet name is the name appearing on the worksheet tab. To run the code, use Alt-F8, to open the Macro dialogue and double click (run) 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.

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