Excel vba隐藏没有filter的空行

我使用此代码创build一个新工作表，并列出工作簿中的所有工作表名称，其中间有空行，然后隐藏工作表名称之间的所有空行。

但是，它接pipe一分钟以完成是否有一个更有效的方法来做到这一点？

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 

Answer 1

而不是暴力方式：

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

你应该能够简单地做到：

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

使用SpecialCells(xlCellTypeBlanks)应该几乎是瞬间的（即使在我的testing中，只需要几秒钟的时间来进行暴力破解）。

Answer 2

问题是每行有16384个单元格，并且正在迭代16384 * (Sheet Count - 1) * 18单元格

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

这个更好

 For Each rw In Rng.Rows If Not rw.Cells(1,1).Value > 0 Then rw.Hidden = True End If Next rw 

我会隐藏行添加表名称：

 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