Copying top 5 rows after applying filters

[akeem1234]

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.

 

[kevin9999]

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
	A	B	C
1	HDR1	HDR2	HDR3
2	a	Row 2	first a
3	b	Row 3	data
4	c	Row 4	data
5	a	Row 5	second a
6	b	Row 6	data
7	c	Row 7	data
8	a	Row 8	third a
9	b	Row 9	data
10	c	Row 10	data
11	a	Row 11	fourth a
12	b	Row 12	data
13	c	Row 13	data
14	a	Row 14	fifth a
15	b	Row 15	data
16	c	Row 16	data
17	a	Row 17	sixth a
18	b	Row 18	data
19	c	Row 19	data
20	a	Row 20	seventh a
21	b	Row 21	data
22	c	Row 22	data
23	a	Row 23	eighth a
24	b	Row 24	data
25	c	Row 25	data
Sheet1

When you run this 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
	A	B	C
1	HDR1	HDR2	HDR3
2	a	Row 2	first a
3	a	Row 5	second a
4	a	Row 8	third a
5	a	Row 11	fourth a
6	a	Row 14	fifth a
7
Sheet2

 

[akeem1234]

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

 

[akeem1234]

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

 

[akeem1234]

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

 

[HaHoBe]

Hi akeem1234,

maybe

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

 

[akeem1234]

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

 

[akeem1234]

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

 

[akeem1234]

the worksheet is sheet 3 on the work book

 

[HaHoBe]

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
	A	B	C	D	E	F	G	H	I	J	K	L	M	N						T	U
1	john	charlie	HDR3	HDR4	HDR5	HDR6	HDR7	HDR8	HDR9	HDR10	HDR11	HDR12	HDR13	sean
2	3230	1,790621	990	3949	4380	2589	63	2708	593	2694	4007	120	3341	4056
3	3850	1,01746	4361	2240	2042	226	64	855	3148	4127	1455	4682	299	4080
4	3042	2,307418	2096	293	2941	4259	64	2790	4337	618	767	4489	4119	2023
5	4583	0,388978	2512	939	3352	3347	67	2641	3721	4789	69	4847	2215	3649
6	2022	2,93447	3870	3403	4364	1701	71	940	1771	2240	1266	2499	4270	501
7	4317	2,446009	1013	879	3378	977	77	3646	4499	303	2732	1781	2778	123
8	2653	0,765897	1477	2030	2656	2828	87	552	3179	549	963	4049	1328	713
9	2136	1,420055	344	3916	1370	1975	105	3409	3906	822	3162	4041	929	537
10	3339	2,844861	2214	175	4386	977	106	2934	4913	1008	811	1499	116	1178
11	2940	0,627604	1435	3083	3050	2826	110	1607	1811	741	4330	4391	195	3468
12	517	2,602904	2825	3775	3990	4822	118	2363	4431	2160	2854	3016	798	2957
13	4970	0,788376	286	2647	3100	4785	123	1539	4960	1695	908	2872	965	4814
14	256	1,207683	3022	799	4400	1469	127	4552	1060	4869	2758	903	382	2593
15	3757	0,728773	3715	3809	3840	2213	133	3433	3190	1701	1572	3523	3189	2780
16	3656	0,635397	1304	3836	284	4516	135	3385	2524	2263	4673	2533	88	2027
17	4231	2,176471	2406	4441	2963	4577	143	1047	2650	3882	2393	1233	4236	4097
18	3852	0,168816	2216	418	2694	1758	150	2932	1005	479	3940	2206	2827	3453
19	4091	1,298834	1052	4721	791	1148	155	819	1380	74	4926	2678	73	200
20	4456	1,256465	4763	2316	3213	1875	156	143	2976	963	4447	3631	4620	160
21	3103	0,667531	3866	537	2756	3085	158	2494	1350	721	2649	799	1351	3537
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
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
1	john	charlie	HDR3	HDR4	HDR5	HDR6	HDR7	HDR8	HDR9	HDR10	HDR11	HDR12	HDR13	sean
4	1415	2,754064	3975	1645	2135	848	1842	3558	4785	118	3331	3931	1797	4940
6	194	2,847463	3632	241	3134	2236	4091	3376	4722	2826	3832	458	1177	4918
7	1921	2,584508	1574	3635	4029	259	3158	3329	734	4696	1583	1457	3005	4908
10	3211	2,894785	1068	1906	1973	2283	2409	4934	3693	4120	4278	3903	4320	4898
12	723	2,564071	827	3144	984	3518	1574	4220	3849	4911	2332	2047	1569	4896
YourSheet

and

MrE_1228923_1702D0E_copying top 5 rows_230214.xlsm
	T	U
3	1415	4940
4	194	4918
5	1921	4908
6	3211	4898
7	723	4896
YourSheet

for the target range.

Code used:

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