How do I copy the top 25 rows of filtered data?

Thank you so much for your quick response, but there must be a way to do it with filters.  This portion is only a smaller part of a larger macro and I don't want to have to edit it to add a temporary sheet, and then add code to delete the sheet later, etc.

What do you think, is this as good as it gets?

just to elaborate on recording the macro,

assuming your data is in sheet 1 and you've sheet 2 and 3 present also
when you have your filtered data
Edit, goto, special, Choose "visible cells only"
In sheet2 paste the data (which will have the header)
sort in descending order the column you want the top25 from
copy rows 1 - 26 (header + top25)
paste into sheet3, which is your result.

I had done this on a mock up which is attached. you can filter by a, b, c, d with over 25 results for each. sheet3 will only have the top25.

You can autofilter the top 25 items in H - see below

Cheers

Dave

Columns("H").AutoFilter Field:=1, Criteria1:="25", Operator:=xlTop10Items

                                              

1:

sorry I was mid mock up there.

The overhead of using a temp sheet outweighs trying to keep it all within the filtering, as you can see there's not that much code in the macro as it's using alot of built in functions (copy visible, sorting descending, then copy and pasting again).

I rarely use filters so there might be a very straight forward answer. But that's my stab at it ;)

Off to bed now incase you're wondering about the "radio silence" for the next few hours from my side.

Brett to the rescue :) o//

Thank you Brett! But keep in mind, I'm also filtering it for a value in Column A as well, and how would I tell the Macro to copy the top 25 items every time, without picking up all of the hidden rows?

This is what I have so far, I'm sooo close but it only copies the top  25 hidden rows for some reason:
Range("A1").Select
    Selection.AutoFilter Field:=1, Criteria1:="Small Business (SB - IL/IN)"
    Selection.SpecialCells (xlCellTypeVisible)
    ActiveCell.Offset(1, 0).Rows("1:25").EntireRow.Select
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    ActiveWindow.ScrollWorkbookTabs Sheets:=1
    ActiveWindow.ScrollWorkbookTabs Sheets:=1
    ActiveWindow.ScrollWorkbookTabs Sheets:=1
    ActiveWindow.ScrollWorkbookTabs Sheets:=1
    Sheets("SB - Top 25 - IL&IN").Select
    Range("A1").Select
    Selection.End(xlUp).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(5, 0).Range("A1").Select
    ActiveSheet.Paste
End Sub

And thank you again, but can you tell me where would the Auto Filter of Column H fit into the macro I have so far, and can you tell me what I've done wrong based on what I posted above??

Oh and sorry, one last comment before I go to sleep, When I try the Top 25 feature to Auto Filter  Column H , (not in a macro) It only gives me 17 visible rows, not 25. I think it's because I already have another filter in Column A.  And Yes there are definitely more than 17 rows that fit my criteria.

I hit the wrong button, please keep the solutuions coming, I didn't mean to close it.

> When I try the Top 25 feature to Auto Filter  Column H , (not in a macro) It only gives me 17 visible rows, not 25.  I think it's because I already have another filter in Column A

I think that VBA a copy of the sheet to a (hidden) working sheet and then  processing it is the way to go. It's minor coding wise

Do you want us to proceed that way?

Cheers

Dave

You could try something like this:

Sub FilterAndCopy25()
   Dim wksSource As Worksheet, wksDest As Worksheet
   Dim strFilter1 As String, strFilter2 As String
   Dim rngFirstCell As Range, rngLastCell As Range, rngData As Range, rngCell As Range
   Dim lngCounter As Long, lngStop As Long
   
   ' sheet to copy from
   Set wksSource = ActiveSheet
   ' sheet to copy to
   Set wksDest = Sheets("Target")
   
'   strFilter1 = "Small Business (SB - IL/IN)"
   ' column A filter
   strFilter1 = "1"
   ' column H filter
   strFilter2 = "a"
   
   With wksSource
      With .Range("A1").CurrentRegion
         .AutoFilter field:=1, Criteria1:=strFilter1
         .AutoFilter field:=8, Criteria1:=strFilter2
      End With
      Set rngData = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible)
      lngStop = Application.Min(rngData.Count, 25)
      ' check there's data to copy!
      If lngStop > 1 Then
         For Each rngCell In rngData
            If lngCounter = 1 Then
               Set rngFirstCell = rngCell
            ElseIf lngCounter = lngStop Then
               Set rngLastCell = rngCell
               Exit For
            End If
            lngCounter = lngCounter + 1
         Next rngCell
         ' copy data
         .Range(rngFirstCell, rngLastCell).SpecialCells(xlCellTypeVisible).EntireRow.Copy
         wksDest.Cells(.Rows.Count, "A").End(xlUp).Offset(5, 0).PasteSpecial
         Application.CutCopyMode = False
      End If
   End With
End Sub
                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:

Hmm, just re-read the question - is it the top 25 rows by value, or just the top 25 rows by position? (mine does the latter)

Hi Rorya, It's the top 25 by Value.  Thanks so much!

Thanks to you Kris as well! I will try them both shortly.

In that case, mine won't work. I would use an advanced filter instead if you can?

A sample workbook would be useful here. :)

Rorya, Kris:

Per your request, attached is a sample workbook!

Cheers!

Hi Kris, I just gave your VBA code a try, and it ran, but it only returned 15 rows???

Actually, it was 14 rows, and not only that, it only pasted through column "H", I needed the entire  row copied and pasted through Column "AF".

Cheers!

Brett DJ,

In the interim, can we try the VBA Code to paste to a hidden sheet? Would you be able to write that for me?

Cheers!

Hang on Kris, I just ran it again, because in my sample workbook, there were some cells in Column A that were "#N/A, and when I replaced them with a value, I think it worked, let me test again but you may be my hero and go to the top of the Genius List, because this stumped several very intelligent people!

Try

Sub kTest()
Dim fRng As Range, tmpSht   As Worksheet, ws As Worksheet
Dim DestSht As Worksheet, Crit, Top25, SortCol As Long
Dim k(), i As Long, n As Long, Hdr, x, c As Long
 
Crit = "Small Business (SB - IL/IN)"
 
Set ws = Sheets("Detail-IL IN")
Set DestSht = Sheets("SB - Top 25 - IL&IN")
Hdr = DestSht.Range("a4:n4")
With Application
    .ScreenUpdating = 0
    .DisplayAlerts = 0
End With
With ws.UsedRange
    .AutoFilter Field:=1, Criteria1:=Crit
    Set fRng = .SpecialCells(xlCellTypeVisible)
End With
    Set tmpSht = Sheets.Add
    fRng.Copy: tmpSht.Range("a1").PasteSpecial xlPasteValues
    With tmpSht.UsedRange
        SortCol = .Rows(1).Find("Principal Bal", lookat:=xlWhole).Column
        .Sort .Cells(2, SortCol), xlDescending
        Top25 = .Cells(1, 2).Resize(26, .Columns.Count - 1)
    End With
    ReDim k(1 To 25, 1 To 14)
    For i = 2 To UBound(Top25, 1)
        If Len(Top25(i, 1)) Then
            n = n + 1
            For c = 1 To UBound(Top25, 2)
                x = Application.Match(Top25(1, c), Hdr, 0)
                If Not IsError(x) Then k(n, x) = Top25(i, c)
            Next
        End If
    Next
    With DestSht.Range("a" & Rows.Count).End(xlUp).Offset(1)
        .Resize(n, 14).Value = k
    End With
    tmpSht.Delete
    ws.AutoFilterMode = False
With Application
    .ScreenUpdating = 1
    .DisplayAlerts = 1
    .CutCopyMode = 0
End With
End Sub

                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:

Thanks Kris,  Actually they both work, except the 2nd one cuts off the Header Row, can you add that back in?  I am going to accept both your solutions! You are the very best, Thank You.

This was quite a challenge and this solution from Kris rose to the challenge.  I am so very grateful to you for taking the time out to help a novice like me!

Kris, This is closed, but as I mentioned above the Header Row wasn't coming through, how can I fix that?
Thanks!