CODEWITHSUNDEEP
vbaexcel
luke
luke

Reputation: 482

Excel vba hide empty rows without filter

I use this code to create a new sheet and list all the sheet names in the workbook with empty rows in between them and then it hides all the empty rows in between the sheet name.

But its taking over over a min to complete is there a more efficient way of doing this?

Sub ListAllSheetNames()
'Disabling the following to speed up the vba code
ActiveSheet.DisplayPageBreaks = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'code to create new sheet and list all sheet names in workbook
Dim xWs As Worksheet
On Error Resume Next
xTitleId = "All Sheet Names"
Application.Sheets(xTitleId).Delete
Application.Sheets.Add.Index
Set xWs = Application.ActiveSheet
xWs.Name = xTitleId
For i = 2 To Application.Sheets.Count
  'Edit this to adjust the row spacing, number after *
  xWs.Range("A" & ((i - 2) * 18) + 1) = Application.Sheets(i).Name
Next

'Hides all empty rows
Set Rng = Range("A1", Range("A15000").End(xlUp))

For Each cel In Rng
  If Not cel.Value > 0 Then
    cel.EntireRow.Hidden = True
  End If
Next cel

Range("A1").Select

'UnDisabling
ActiveSheet.DisplayPageBreaks = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Upvotes: 2

Views: 1069

Answers (2)

user6432984
user6432984

Reputation:

The problem is that there are 16384 cells in each row and you are iterating through 16384 * (Sheet Count - 1) * 18 cells

For Each cel In Rng

    If Not cel.Value > 0 Then

        cel.EntireRow.Hidden = True

    End If
Next cel

This is better

For Each rw In Rng.Rows

    If Not rw.Cells(1,1).Value > 0 Then

        rw.Hidden = True

    End If
Next rw

I would hide the rows as I add the Sheet Names:

Sub ListAllSheetNames()
    Const xTitleId = "All Sheet Names"
    Application.ScreenUpdating = False

    'code to create new sheet and list all sheet names in workbook
    Dim xWs As Worksheet, ws As Worksheet
    Dim i As Long
    On Error Resume Next
    DeleteWorksheet xTitleId

    Application.Sheets.Add

    Set xWs = Application.ActiveSheet
    xWs.Name = xTitleId
    i = 1
    For Each ws In Sheets
        xWs.Cells(i, 1).Value = ws.Name
        xWs.rows(i + 1).Resize(17).Hidden = True
        i = i + 18
    Next

    Range("A1").Select

    Application.ScreenUpdating = True
End Sub

Sub DeleteWorksheet(SheetName As String)
    Application.DisplayAlerts = False 'Resets when the Sub Exits
    On Error Resume Next 'Resets when the Sub Exits
    Sheets(SheetName).Delete
End Sub

Upvotes: 1

David Zemens
David Zemens

Reputation: 53623

Instead of the brute-force approach:

For Each cel In Rng

    If Not cel.Value > 0 Then

        cel.EntireRow.Hidden = False

    End If
Next cel

You should be able to do simply:

Rng.SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True

Using SpecialCells(xlCellTypeBlanks) should be nearly instantaneous (although even in my tests,it only took a few seconds to do the brute force iteration).

Upvotes: 6

Related Questions