Copying top 5 rows after applying filters

akeem1234

New Member
Joined
Nov 7, 2022
Messages
26
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
The issue I'm having is that I want to copy the first 5 rows after a filter has be applied which has changed the order of the row number on the side, i want the macros to always take the top 5 of what i have filtered but it will always look for the number row instead of the row numbers that are in the top 5 of my filter. How could i get around this, please help.
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Obviously I haven't the faintest idea what your data / sheets look like because you haven't provided that information - so the following is offered for demonstration purposes only. If you can provide a copy of what your data looks like via the XL2BB add in, or sharing your file via Dropbox, Google drive or similar, then I can adjust the code to suit your needs.

Starting with this sheet:
top 5.xlsm
ABC
1HDR1HDR2HDR3
2aRow 2first a
3bRow 3data
4cRow 4data
5aRow 5second a
6bRow 6data
7cRow 7data
8aRow 8third a
9bRow 9data
10cRow 10data
11aRow 11fourth a
12bRow 12data
13cRow 13data
14aRow 14fifth a
15bRow 15data
16cRow 16data
17aRow 17sixth a
18bRow 18data
19cRow 19data
20aRow 20seventh a
21bRow 21data
22cRow 22data
23aRow 23eighth a
24bRow 24data
25cRow 25data
Sheet1


When you run this code:

VBA Code:
Option Explicit
Sub Copy_Top_5()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    
    Dim LRow As Long
    LRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    Dim c As Range, i As Long
    i = 1
    
    With ws1.Range("A1").CurrentRegion
        .AutoFilter 1, "a"
        For Each c In ws1.Range("A2:A" & LRow)
            If c.EntireRow.Hidden = False Then
                If i <= 5 Then
                    c.Resize(1, 3).Copy ws2.Range("A" & ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1)
                    i = i + 1
                End If
            End If
        Next c
        .AutoFilter
    End With
End Sub

You get this on a second sheet:
top 5.xlsm
ABC
1HDR1HDR2HDR3
2aRow 2first a
3aRow 5second a
4aRow 8third a
5aRow 11fourth a
6aRow 14fifth a
7
Sheet2
 
Upvote 0
apologies i will send you a copy of what type of table i am dealing with, its because my data is sensitive but i will randomise it
 
Upvote 0
i see what you have done and what i would want is to copy it on the sheet sheet in a specific range, so instead of a new sheet, it goes to the same sheet in range T3:U7
 
Upvote 0
also the filter changes a column from largest to smallest which is why the rows change and then i want to take the top 5 from that filter
 
Upvote 0
Hi akeem1234,

maybe

VBA Code:
Public Sub MrE_1228923_1702D0E()
' https://www.mrexcel.com/board/threads/copying-top-5-rows-after-applying-filters.1228923/
  Dim ws1 As Worksheet
  Dim LRow As Long
  Dim rngCopy As Range
  Dim rngVisColA As Range
  Dim rngCell As Range
  Dim rngArea As Range
  Dim lngCounter As Long
  Dim blnEnd As Boolean
  
  Const clngMax As Long = 5
  
  Set ws1 = Worksheets("Sheet1")
  LRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
  
  With ws1.Range("A1:C" & LRow)
    .AutoFilter 1, "a"
    If WorksheetFunction.CountA(.Columns(1), "a") > 0 Then
      Set rngVisColA = .Range("A1:A" & LRow).SpecialCells(xlCellTypeVisible)
      For Each rngArea In rngVisColA.Areas
        If blnEnd Then Exit For
        For Each rngCell In rngArea.Cells
          If blnEnd Then Exit For
          lngCounter = lngCounter + 1
          If rngCell.Row > 1 Then
            If rngCopy Is Nothing Then
              Set rngCopy = rngCell.Resize(1, 3)
            Else
              Set rngCopy = Union(rngCopy, rngCell.Resize(1, 3))
            End If
          End If
          If lngCounter = clngMax + 1 Then blnEnd = True
        Next rngCell
      Next rngArea
      rngCopy.Copy .Range("T3")
    End If
    .AutoFilter
  End With
  
  Set rngCopy = Nothing
  Set rngVisColA = Nothing
End Sub

Please specify what type of table you are talking about.

Ciao,
Holger
 
Upvote 0
Looking at the data i sent you. I first filtered the charlie column to greater than or equal to 2 and then i filtered sean to largest to smallest. and then that is when i will need to take the top 5 of john and the corresponding top 5 from sean
 

Attachments

  • Annotation 2023-02-14 163600.png
    Annotation 2023-02-14 163600.png
    111.9 KB · Views: 4
Upvote 0
once i have now copied those top 5 i want to paste it in a range on the same sheet as shown in the image. the range i want it to copy to is T3:T7 for john top 5 and u3:u7 for sean top 5
 

Attachments

  • Annotation 2023-02-14 164018.png
    Annotation 2023-02-14 164018.png
    85.5 KB · Views: 2
Upvote 0
Hi akeem1234,

please take a look at XL2BB - Excel Range to BBCode which is really helpful to display parts of the worksheets opposed to pictures which do not show all header and row information and cannot be loaded in Excel.

Showing only the top 20 rows in the DataRange (which holds 830 rows in total):

MrE_1228923_1702D0E_copying top 5 rows_230214.xlsm
ABCDEFGHIJKLMNTU
1johncharlieHDR3HDR4HDR5HDR6HDR7HDR8HDR9HDR10HDR11HDR12HDR13sean
232301,7906219903949438025896327085932694400712033414056
338501,017464361224020422266485531484127145546822994080
430422,3074182096293294142596427904337618767448941192023
545830,3889782512939335233476726413721478969484722153649
620222,9344738703403436417017194017712240126624994270501
743172,446009101387933789777736464499303273217812778123
826530,765897147720302656282887552317954996340491328713
921361,4200553443916137019751053409390682231624041929537
1033392,8448612214175438697710629344913100881114991161178
1129400,627604143530833050282611016071811741433043911953468
125172,6029042825377539904822118236344312160285430167982957
1349700,78837628626473100478512315394960169590828729654814
142561,20768330227994400146912745521060486927589033822593
1537570,72877337153809384022131333433319017011572352331892780
1636560,63539713043836284451613533852524226346732533882027
1742312,17647124064441296345771431047265038822393123342364097
1838520,168816221641826941758150293210054793940220628273453
1940911,2988341052472179111481558191380744926267873200
2044561,25646547632316321318751561432976963444736314620160
2131030,66753138665372756308515824941350721264979913513537
YourSheet


I'm no friend to only sort one column in a range but the result after running the code looks like this for my DataRange (only those rows of interest)

MrE_1228923_1702D0E_copying top 5 rows_230214.xlsm
ABCDEFGHIJKLMN
1johncharlieHDR3HDR4HDR5HDR6HDR7HDR8HDR9HDR10HDR11HDR12HDR13sean
414152,7540643975164521358481842355847851183331393117974940
61942,8474633632241313422364091337647222826383245811774918
719212,5845081574363540292593158332973446961583145730054908
1032112,894785106819061973228324094934369341204278390343204898
127232,5640718273144984351815744220384949112332204715694896
YourSheet


and

MrE_1228923_1702D0E_copying top 5 rows_230214.xlsm
TU
314154940
41944918
519214908
632114898
77234896
YourSheet


for the target range.

Code used:

VBA Code:
Public Sub MrE_1228923_1702D0E_Update()
' https://www.mrexcel.com/board/threads/copying-top-5-rows-after-applying-filters.1228923/
  Dim ws1 As Worksheet
  Dim LRow As Long
  Dim rngCopy As Range
  Dim rngVisColA As Range
  Dim rngCell As Range
  Dim rngArea As Range
  Dim lngCounter As Long
  Dim blnEnd As Boolean
  
  Const clngMax As Long = 5
  
  Set ws1 = Worksheets(3)                         'Third worksheet in workbook, I'd preferred to use
                                                  'either the sheetname or the codename instead of Index here
  LRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
  
  With ws1.Range("A1").CurrentRegion
    .AutoFilter 2, Criteria1:=">=2", Operator:=xlAnd
    With ws1.AutoFilter.Sort
      .SortFields.Clear
      .SortFields.Add2 Key:=ws1.Range("N1", ws1.Range("N" & ws1.Rows.Count).End(xlUp)), _
                        SortOn:=xlSortOnValues, _
                        Order:=xlDescending, _
                        DataOption:=xlSortNormal
      .Header = xlYes
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
    End With
    If WorksheetFunction.CountA(.Columns(1)) > 0 Then
      Set rngVisColA = .Range("A1:A" & LRow).SpecialCells(xlCellTypeVisible)
      For Each rngArea In rngVisColA.Areas
        If blnEnd Then Exit For
        For Each rngCell In rngArea.Cells
          If blnEnd Then Exit For
          lngCounter = lngCounter + 1
          If rngCell.Row > 1 Then
            If rngCopy Is Nothing Then
              Set rngCopy = Union(rngCell, rngCell.Offset(0, 13))
            Else
              Set rngCopy = Union(rngCopy, rngCell, rngCell.Offset(0, 13))
            End If
          End If
          If lngCounter = clngMax + 1 Then blnEnd = True
        Next rngCell
      Next rngArea
      rngCopy.Copy .Range("T3")
    End If
    .AutoFilter
  End With
  
  Set rngCopy = Nothing
  Set rngVisColA = Nothing
End Sub

Ciao,
Holger
 
Upvote 1
Solution

Forum statistics

Threads
1,223,099
Messages
6,170,107
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top