Macro appears to be deleting data but not line and shifting data up.

[ghrek]

Hi

I have this macro and when I run it appears to be deleting the data and the gridlines but not the actual rows and thus not shifting all the data up together thats supposed to be there when complete.

Any ideas why?

Sub MonthEnd()
    Dim rCl As Range, rDelete As Range
    Dim sSht As String

    sSht = InputBox("Enter new sheet name", "New Month Sheet")

    If Len(sSht) = 0 Then
        MsgBox "You must enter a name for the new sheet", vbCritical, "Quitting"
        Exit Sub
        ''/// copy current sheet
    Else: ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = sSht
        For Each rCl In ActiveSheet.Range("AB10:AB9999").Cells
            If rCl.Value = 0 Then
                If rDelete Is Nothing Then
                    Set rDelete = Range("A" & rCl.Row, rCl)
                Else: Set rDelete = Union(rDelete, Range("A" & rCl.Row, rCl))
                End If
            End If
        Next rCl
        If Not rDelete Is Nothing Then rDelete.Delete
        MsgBox "Month End successfully completed", vbInformation, "Done"
    End If
End Sub

 

[rollis13]

Here, made some fixing, now should do what you are after:

Option Explicit

Sub MonthEnd()
    Dim rCl    As Range, rDelete As Range
    Dim sSht   As String

    sSht = InputBox("Enter new sheet name", "New Month Sheet")
    
    If Len(sSht) = 0 Then
        MsgBox "You must enter a name for the new sheet", vbCritical, "Quitting"
        Exit Sub
    Else
        '/// copy current sheet
        ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = sSht
        For Each rCl In ActiveSheet.Range("AB10:AB9999").Cells '<- this is the range "ABxx:AByy"
            If rCl.Value = 0 Then
                If rDelete Is Nothing Then
                    Set rDelete = Range("AB" & rCl.Row) '<- changed, was "A"
                Else
                    Set rDelete = Union(rDelete, Range("AB" & rCl.Row)) '<- changed, was "A"
                End If
            End If
        Next rCl
        If Not rDelete Is Nothing Then rDelete.Delete Shift:=xlUp '<- changed, added shift up
        'If Not rDelete Is Nothing Then rDelete.EntireRow.Delete Shift:=xlUp '<- use instead of above if entire row has to be deleted
        MsgBox "Month End successfully completed", vbInformation, "Done"
    End If
    
End Sub

 

[ghrek]

Here, made some fixing, now should do what you are after:

Option Explicit

Sub MonthEnd()
    Dim rCl    As Range, rDelete As Range
    Dim sSht   As String

    sSht = InputBox("Enter new sheet name", "New Month Sheet")
   
    If Len(sSht) = 0 Then
        MsgBox "You must enter a name for the new sheet", vbCritical, "Quitting"
        Exit Sub
    Else
        '/// copy current sheet
        ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = sSht
        For Each rCl In ActiveSheet.Range("AB10:AB9999").Cells '<- this is the range "ABxx:AByy"
            If rCl.Value = 0 Then
                If rDelete Is Nothing Then
                    Set rDelete = Range("AB" & rCl.Row) '<- changed, was "A"
                Else
                    Set rDelete = Union(rDelete, Range("AB" & rCl.Row)) '<- changed, was "A"
                End If
            End If
        Next rCl
        If Not rDelete Is Nothing Then rDelete.Delete Shift:=xlUp '<- changed, added shift up
        'If Not rDelete Is Nothing Then rDelete.EntireRow.Delete Shift:=xlUp '<- use instead of above if entire row has to be deleted
        MsgBox "Month End successfully completed", vbInformation, "Done"
    End If
   
End Sub

Many thanks

 

[rollis13]

Glad having been of some help.