Excek VBA Delete Blank Rows only allow 1 Blank Row

[Biz]

Dear All

I have named range called Name which equals to =Sheet1!$A$1:$A$7.
Since I want to allow only 1 blank row in a named range. Therefore,
I want to delete row 7 then my named range will have only one row.

Please note the example provided is simply example and sometimes there could be 11-20 blank rows but the end goal to have one 1 blank row in a named range.

Could someone please help me create code which delete rows from bottom and stops when there is only 1 blank row in a named range?

Your help would be greatly appreciated.


Sheet1

<TABLE style="BACKGROUND-COLOR: #ffffff; PADDING-LEFT: 2pt; PADDING-RIGHT: 2pt; FONT-FAMILY: Arial,Arial; FONT-SIZE: 10pt" border=1 cellSpacing=0 cellPadding=0><COLGROUP><COL style="WIDTH: 30px; FONT-WEIGHT: bold"><COL style="WIDTH: 64px"></COLGROUP><TBODY><TR style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt; FONT-WEIGHT: bold"><TD> </TD><TD>A</TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">1</TD><TD style="FONT-WEIGHT: bold">Name</TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">2</TD><TD>Tom</TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">3</TD><TD>Mary</TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">4</TD><TD>Tony</TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">5</TD><TD>Andrew</TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">6</TD><TD> </TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">7</TD><TD> </TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">8</TD><TD> </TD></TR><TR style="HEIGHT: 17px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">9</TD><TD> </TD></TR></TBODY></TABLE>


Biz

 

[Jon von der Heyden]

Hi

You could use a dynamic named range. So instead of =Sheet1!$A$1:$A$7 in your names RefersTo: box, put in:

=Sheet1!$A$1:INDEX(Sheet1!$A:$A,MATCH(REPT("z",255),Sheet1!$A:$A,TRUE)+1,1)

 

[Biz]

Hi Mate,

I am consistently updating named range.

Step 1 ClearContents
Step 2 Insert Additional Rows if required based on new data
Step 2 Update Named Range with new data
Step 3 To Delete excess blank rows except leave one blank row.

I need vba not dynamic formula. VBA must delete blank rows except leave one blank row.

Biz

 

[JoeMo]

Maybe you can adapt this for your requirement:

Sub LeaveOneBlank()
Dim blanks As Range
With Range("Name")
    On Error Resume Next
    Set blanks = .SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If Not blanks Is Nothing Then
        If blanks.Cells.Count > 1 Then
            Do Until blanks.Cells.Count = 1
                For Each c In blanks
                    c.Delete shift:=xlUp
                Next c
            Loop
        End If
    End If
End With

End Sub

 

[Biz]

Hi JoeMo,

Thanks for your hlelp and code mate. My final code is below.

Sub DeleteBK()
    Dim z As Long, BlankRows As Long, UsedRng As Long, rCount As Long, r As Long
    Dim aDeleteList
    Dim dRng As Range
    
    'Speeding Up VBA Code
    With Application
        .ScreenUpdating = False 'Prevent screen flickering
        '.Calculation = xlCalculationManual 'Preventing calculation
        .DisplayAlerts = False 'Turn OFF alerts
        .EnableEvents = False 'Prevent All Events
    End With
    
    aDeleteList = Range("dList").Value
    
    'Delete blanks rows and only LeaveOneBlank
    For z = LBound(aDeleteList) To UBound(aDeleteList)
        
        Set dRng = Range(aDeleteList(z, 1))
        BlankRows = Application.CountBlank(dRng)
        UsedRng = Application.CountA(dRng)
        
        If dRng Is Nothing Then Exit Sub
        If dRng.Areas.Count > 1 Then Exit Sub
        With dRng
            rCount = .Rows.Count
            For r = rCount To 1 Step -1
                If Application.CountA(.Rows(r)) = 0 _
                    And (r > UsedRng + 1 = True) Then
                .Rows(r).EntireRow.Delete
            End If
        Next r
    End With
Next z
Erase aDeleteList ' deletes the variable contents, free some memory
'Release memory
    Set dRng = Nothing
'Speeding Up VBA Code
    With Application
        .ScreenUpdating = True 'Prevent screen flickering
        '.Calculation = xlAutomatic 'Preventing calculation
        .DisplayAlerts = True 'Turn OFF alerts
        .EnableEvents = True 'Prevent All Events
    End With
End Sub

Biz