Код VBA для замены таблицы фильтрами с отфильтрованными данными

Question

Существуют ли какие-либо хорошие & эффективный способ с VBA для изменения таблицы со многими фильтрами, применяемыми для удаления всех остальных данных, которые не имеют значения (не фильтруются)? Цель состоит в том, чтобы удалить из xlsm данные, которые вам не нужны. Благодарю.

Answer 1

Это то, что вы хотите ???

Sub DropHidden() 
    Dim EquivRange As Range, r As Range 
    Dim lo As ListObject 
    Dim nFirstRow As Long, nLastRow As Long 
    Set lo = ActiveSheet.ListObjects(1) 

    With lo 
     Set EquivRange = .DataBodyRange 
     nFirstRow = EquivRange.Row 
     nLastRow = EquivRange.Rows.Count + EquivRange.Row - 1 
     For i = nLastRow To nFirstRow Step -1 
     Set r = Cells(i, 1).EntireRow 
     If r.Hidden Then 
      r.Delete 
     End If 
     Next i 
     .Unlist 
    End With 
End Sub 

Answer 2

Как иногда упоминаются хотя вопросы таблиц, но на самом деле ссылка относится к диапазонам данных, а также не ясно, чтобы требование, является ли удалить целые строки или только отфильтрованную часть строки. Я обеспечиваю четыре процедуры высоких будет работать в следующих ситуациях:

1. таблицы Excel - Удалить Нефильтруемые товары - весь ряд

   Sub Lob_Delete_NonFilteredItems_EntireRow() 
   Dim Lob As ListObject, rRow As Range 
       'Set Lob = ActiveSheet.ListObjects(TblName)  'Set Table Name as required 
       Set Lob = ActiveSheet.ListObjects(1)   'Set Table Index as required 
       For Each rRow In Lob.DataBodyRange.Rows 
        If rRow.EntireRow.Hidden Then rRow.EntireRow.Delete 
       Next 
   End Sub 
   

2. Excel Таблица - Удалить Нефильтруемые товары - Row Перемещение вверх

   Sub Lob_Delete_NonFilteredItems_RowShiftUp() 
   Dim Lob As ListObject, rVsble As Range, rRow As Range, rDel As Range 
       Rem Set List Object - Excel Table 
       'Set Lob = ActiveSheet.ListObjects(TblName)  'Set Table Name as required 
       Set Lob = ActiveSheet.ListObjects(1)   'Set Table Index as required 
       Rem Set Filtered Range 
       Set rVsble = Lob.DataBodyRange.SpecialCells(xlCellTypeVisible) 
       Rem Set Filters Off 
       rVsble.Cells(1).Activate 
       On Error Resume Next 
       ActiveSheet.ShowAllData 
       On Error GoTo 0 
       Rem Set Range To be Deleted 
       For Each rRow In Lob.DataBodyRange.Rows 
        If Application.Intersect(rRow, rVsble) Is Nothing Then 
         If rDel Is Nothing Then 
          Set rDel = rRow 
         Else 
          Set rDel = Union(rDel, rRow) 
       End If: End If: Next 
       Rem Delete Rows 
       rDel.Delete Shift:=xlUp 
   End Sub 
   

3. Диапазон Excel - Удалить Нефильтруемые товары - Весь ряд

   Sub Rng_Delete_NonFilteredItems_EntireRow() 
   Dim rBdy As Range, rRow As Range 
       Rem Validate Worksheet AutoFilter 
       If ActiveSheet.AutoFilter Is Nothing Then Exit Sub 
       Rem Set AutoFilter Range 
       With ActiveSheet.AutoFilter.Range 
        Set rBdy = .Offset(1, 0).Resize(-1 + .Rows.Count) 
       End With 
       For Each rRow In rBdy.Rows 
        If rRow.EntireRow.Hidden Then 
         rRow.EntireRow.Delete 
        End If 
       Next 
   End Sub 
   

4. Excel Range - Удалить Нефильтруемые товары - Row Сдвиг вверх

   Sub Rng_Delete_NonFilteredItems_RowShiftUp() 
   Dim rBdy As Range, rVsble As Range, rRow As Range, rDel As Range 
       Rem Validate Worksheet AutoFilter 
       If ActiveSheet.AutoFilter Is Nothing Then Exit Sub 
       Rem Set AutoFilter Range 
       With ActiveSheet.AutoFilter.Range 
        Set rBdy = .Offset(1, 0).Resize(-1 + .Rows.Count) 
       End With 
       Rem Set Filtered Range 
       Set rVsble = rBdy.SpecialCells(xlCellTypeVisible) 
       Rem Set Filters Off 
       On Error Resume Next 
       ActiveSheet.ShowAllData 
       On Error GoTo 0 
       Rem Set Range To be Deleted 
       For Each rRow In rBdy.Rows 
        If Application.Intersect(rRow, rVsble) Is Nothing Then 
         If rDel Is Nothing Then 
          Set rDel = rRow 
         Else 
          Set rDel = Union(rDel, rRow) 
       End If: End If: Next 
       Rem Delete Rows 
       rDel.Delete Shift:=xlUp 
   End Sub