Keep Top 5 Lines of Filtered Range - Delete the rest

[SimonGeoghegan]

Hi All,

I have the following loop code which filters my data for me. Once filtered, I want to keep the first top 5 rows of information and delete the rest.

[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]    'Loop to remove risks except for Top 5
    
    x = 1
    
    Do Until x = 52
       
    Hospital = Workbooks("PERSONAL.XLSB").Worksheets("Sheet1").Range("AG" & x).Value
        
    ActiveSheet.Range("$A$4:$Y$4").AutoFilter Field:=2, Criteria1:=Hospital, Operator:=xlFilterValues
    ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 1).Select
    
    
        If Application.WorksheetFunction.Subtotal(3, Range("A4:A10000")) > 6 Then
        
            Set tbl = ActiveCell.CurrentRegion
            tbl.Offset(5, 0).Resize(tbl.Rows.Count - 1, _
                tbl.Columns.Count).Select
            Range(Selection, Selection.End(xlToRight).End(xlDown)).Select
            Selection.EntireRow.Delete
        
        End If
        
    Range("A4:Y4").AutoFilter
    
    Range("E5").CurrentRegion.Sort Key1:=Range("E4"), _
                                          DataOption1:=xlSortTextAsNumbers, _
                                          Header:=xlYes
                                          [/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]    x = x + 1[/FONT]

The code almost does what I want, in that it filters and deletes but I think there is an issue with the offset because stepping through the code, it seems to change each time (i'm assuming this is because of the previous 5 lines of information that were kept). Can anybody point me in the right direction for amending the code to keep the first 5 rows of filtered data and delete the rest?

Thanks in advance,
Simon

 

[Fluff]

You cannot use CurrentRegion on filtered data, try

   For x = 1 To 52
       
        Hospital = Workbooks("PERSONAL.XLSB").Worksheets("Sheet1").Range("AG" & x).Value
            
        With ActiveSheet
            .Range("$A$4:$Y$4").AutoFilter Field:=2, Criteria1:=Hospital
            .AutoFilter.Range.Offset(6).EntireRow.Delete
        End With
    Next x
    
    Range("A4:Y4").AutoFilter
    
    Range("E5").CurrentRegion.Sort Key1:=Range("E4"), _
                                          DataOption1:=xlSortTextAsNumbers, _
                                          Header:=xlYes

 

[SimonGeoghegan]

Thanks Fluff. This appears to work for the first filter criteria, however when it moves onto the next (and all other subsequent values), it deletes everything. The filtering code works as expected but the issue arises during the

[LEFT][COLOR=#333333][FONT=monospace].AutoFilter.Range.Offset(6).EntireRow.Delete[/FONT][/COLOR][/LEFT]

section of the code.

 

[SimonGeoghegan]

Think i've cracked it. I replaced that piece of code with:

[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif] .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Offset(5, 0).EntireRow.Delete[/FONT]

That seems to do the trick

 

[Fluff]

Glad you sorted it & thanks for the feedback

 

[SimonGeoghegan]

I think I spoke too soon...!

Having ran the code in its entireity - I seem to have a variety of different rows for each filter criteria, sometimes 2, sometimes upwards of 10.

The rest of my code works as expected at least, but looks like its back to the drawing board regarding the original issue

 

[Fluff]

OK, how about

EDIT:
Code removed as it was wrong.

 

[Fluff]

Scrub the previous code and try this instead

    Dim x As Long, i As Long
    Dim Cl As Range
    Dim Hospital As String
    
    For x = 1 To 52
        i = 0
        Hospital = Workbooks("PERSONAL.XLSB").Worksheets("Sheet1").Range("AG" & x).Value
        
        With ActiveSheet
            .Range("$A$4:$Y$4").AutoFilter Field:=2, Criteria1:=Hospital
            For Each Cl In .AutoFilter.Range.Columns(1).SpecialCells(xlVisible)
                i = i + 1
                If i = 6 Then
                    i = Cl.Row - 3
                    Exit For
                End If
            Next Cl
            .AutoFilter.Range.Offset(i).EntireRow.Delete
        End With
    Next x

 

[SimonGeoghegan]

Hi Fluff,

Thanks for this - that works perfectly. Apologies for the delay, I was out of the office!

Thanks,
Simon

 

[Fluff]

Glad to help & thanks for the feedback