Vba Excel ListObject表-从ListObject表中删除筛选/隐藏行
我正在绞尽脑汁想办法从ListObject表中删除筛选/隐藏的行 过滤不是通过代码执行的,而是由用户使用表头过滤器执行的。我想在取消列出ListObject表并执行小计操作之前删除筛选/隐藏的行。如果在取消列出表之前不删除筛选/隐藏的行,这些行将重新出现 当前代码:Vba Excel ListObject表-从ListObject表中删除筛选/隐藏行,vba,excel,listobject,excel-tables,Vba,Excel,Listobject,Excel Tables,我正在绞尽脑汁想办法从ListObject表中删除筛选/隐藏的行 过滤不是通过代码执行的,而是由用户使用表头过滤器执行的。我想在取消列出ListObject表并执行小计操作之前删除筛选/隐藏的行。如果在取消列出表之前不删除筛选/隐藏的行,这些行将重新出现 当前代码: Sub SubTotalParClassification(ReportSheetTitle) Dim ws As Worksheet Dim drng As Range Endcol = ColCalculationEndInd
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
不幸的是,没有xlCellTypeInvisible的特定参数,只有一个用于。要收集所有隐藏行,我们需要找到和可见行的补充,而不是。短期UDF可以解决这个问题
一旦建立了一组隐藏行,就不能简单地删除这些行;你必须循环往复。每个区域将包含一个或多个连续行,这些行可以删除
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
请记住,删除行时从底部开始,向顶部移动被认为是“最佳做法”。非常感谢您,它非常有效,解释也非常清楚!