Excel ListObject表 - 从ListObject表中删除过滤/隐藏的行

Question

我在敲我的头，找到一种方法来从ListObject表中删除过滤/隐藏的行。

过滤不通过代码执行，它由用户使用表头过滤器执行。我想在删除ListObject表和执行小计操作之前删除过滤/隐藏的行。如果我在删除表格之前不删除过滤/隐藏行，这些行会重新出现。

目前代码：

Sub SubTotalParClassification(ReportSheetTitle) 
Dim ws As Worksheet 
Dim drng As Range 

Endcol = ColCalculationEndIndex 
Set ws = Sheets(ReportSheetTitle) 

'CODE TO REMOVE HIDDEN/FILTERED ROWS 
Set lo = ActiveSheet.ListObjects("Entrée") 
For i = 1 To lo.ListRows.Count Step 1 
    If Rows(lo.ListRows(i).Range.Row).Hidden = True Then 
     lo.ListRows(i).Delete 
Next 

' convert the table back to a range to be able to build subtotal 
ws.ListObjects("Entrée").Unlist 
With ws 
    'Select range to Subtotal 
    Set drng = .Range(.Cells(REPORTHEADERROW, REPORTSSTARTCOL),  .Cells(EndRow, Endcol)) 

    'apply Excel SubTotal function 
    .Cells.RemoveSubtotal 
    drng.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(Endcol - 6, Endcol - 5, Endcol - 4, Endcol - 3, Endcol - 2, Endcol - 1) 
    End With 

'Update EndRow 
EndRow = ActiveSheet.Cells(Rows.Count, REPORTSSTARTCOL).End(xlUp).Row 
End Sub 

Answer 1

不幸的是，Range.SpecialCells method没有一个具体的参数xlCellTypeInvisible，只有一个xlCellTypeVisible。为了收集所有隐藏的行，我们需要找到.DataBodyRange property和可见行的恭维，而不是Intersect。一个简短的UDF可以解决这个问题。

一旦隐藏行的Union已建立，您不能简单地删除行;你必须循环通过Range.Areas property。每个区域将包含一个或多个连续的行，这些行可以被删除。

Option Explicit 

Sub wqewret() 
    SubTotalParClassification "Sheet3" 
End Sub 

Sub SubTotalParClassification(ReportSheetTitle) 
    Dim a As Long, delrng As Range 
    With Worksheets(ReportSheetTitle) 
     With .ListObjects("Entrée") 
      'get the compliment of databody range and visible cells 
      Set delrng = complimentRange(.DataBodyRange, .DataBodyRange.SpecialCells(xlCellTypeVisible)) 
      Debug.Print delrng.Address(0, 0) 
      'got the invisible cells, loop through the areas backwards to delete 
      For a = delrng.Areas.Count To 1 Step -1 
       delrng.Areas(a).EntireRow.Delete 
      Next a 
     End With 
    End With 
End Sub 

Function complimentRange(bdyrng As Range, visrng As Range) 
    Dim rng As Range, invisrng As Range 

    For Each rng In bdyrng.Columns(1).Cells 
     If Intersect(visrng, rng) Is Nothing Then 
      If invisrng Is Nothing Then 
       Set invisrng = rng 
      Else 
       Set invisrng = Union(invisrng, rng) 
      End If 
     End If 
    Next rng 
    Set complimentRange = invisrng 
End Function 

请记住，从底部开始并在删除行时朝向顶部工作被认为是“最佳实践”。