Select first 800 visible cells only form a column, even if there are more then 800 visible filtered cells - excel

Question

I need a VBA code, that will allow me to select and copy custom number of visible rows only.
For example: I filtered a column data, and the count of all the visible cells is 1000. However, I want to copy only the first 800 visible cells only out of the 1000 visible cells.

Answer 1

One idea is to get all visible cells using SpecialCells(xlCellTypeVisible) and then loop through and collect them one by one using Application.Union to limit them to your desired amount.
Option Explicit
Public Sub Example()
Dim Top800Cells As Range
Set Top800Cells = GetTopVisibleRows(OfRange:=Range("A:A"), TopAmount:=800)
Top800Cells.Select
End Sub
Public Function GetTopVisibleRows(ByVal OfRange As Range, ByVal TopAmount As Long) As Range
Dim VisibleCells As Range
Set VisibleCells = OfRange.SpecialCells(xlCellTypeVisible)
If VisibleCells Is Nothing Then
Exit Function
End If
Dim TopCells As Range
Dim Count As Long
Dim Row As Range
For Each Row In VisibleCells.Rows
If TopCells Is Nothing Then
Set TopCells = Row
Else
Set TopCells = Application.Union(TopCells, Row)
End If
Count = Count + 1
If Count = TopAmount Then Exit For
Next Row
Set GetTopVisibleRows = TopCells
End Function
If you want to use it as a UDF (user defined function) in a formula SpecialCells(xlCellTypeVisible) is known to fail there (see SpecialCells(xlCellTypeVisible) not working in UDF). And you need to check visibility yourselft:
Public Function GetTopVisibleRows(ByVal OfRange As Range, ByVal TopAmount As Long) As Range
Dim TopCells As Range
Dim Count As Long
Dim Row As Range
For Each Row In OfRange.Rows
If Not Row.EntireRow.Hidden Then
If TopCells Is Nothing Then
Set TopCells = Row
Else
Set TopCells = Application.Union(TopCells, Row)
End If
Count = Count + 1
If Count = TopAmount Then Exit For
End If
Next Row
Set GetTopVisibleRows = TopCells
End Function

Answer 2

Copy First n Rows of SpecialCells(xlCellTypeVisible)
This is usually done to more columns as illustrated in the code.
To apply it just to column A, replace Set rg = ws.Range("A1").CurrentRegion with
Set rg = ws.Range("A1").CurrentRegion.Columns(1)
assuming that the header is in the first worksheet row.
In a nutshell, it loops through the rows (rrg) of each area (arg) of the range (MultiRange, dvrg) counting each row (r) and when it hits the 'mark' (DataRowsCount), it uses this row (Set SetMultiRangeRow = rrg, lrrg) and the first row (frrg) as arguments in the range property to set the required range and reapply the same type of SpecialCells to finally reference the required amount of rows.
Sub ReferenceFirstMultiRangeRows()
' Define constants
Const CriteriaColumn As Long = 1
Const CriteriaString As String = "Yes"
Const DataRowsCount As Long = 800
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
If ws.AutoFilterMode Then ws.AutoFilterMode = False
' Reference the ranges.
Dim rg As Range ' the range (has headers)
Set rg = ws.Range("A1").CurrentRegion ' you may need to use another way!
Dim drg As Range ' the data range (no headers)
Set drg = rg.Resize(rg.Rows.Count - 1).Offset(1)
' Apply the auto filter to the range.
rg.AutoFilter CriteriaColumn, CriteriaString
' Attempt to reference the visible data range ('vdrg').
Dim vdrg As Range
On Error Resume Next
Set vdrg = drg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' Reference the required amount of visible rows ('vdrg').
' Reference the partial range ('vdrg') from the first row
' to the DataRowsCount-th row of the visible range
' and reapply special cells to this range.
If Not vdrg Is Nothing Then ' filtered rows found
Dim lrrg As Range: Set lrrg = SetMultiRangeRow(vdrg, DataRowsCount)
If Not lrrg Is Nothing Then ' there are more rows than 'DataRowsCount'
Dim frrg As Range: Set frrg = vdrg.Rows(1)
Set vdrg = ws.Range(frrg, lrrg).SpecialCells(xlCellTypeVisible)
'Else ' the visible data range is already set; do nothing
End If
'Else ' no filtered rows found; do nothing
End If
ws.AutoFilterMode = False ' remove the auto filter
If vdrg Is Nothing Then
MsgBox "No filtered rows.", vbExclamation
Exit Sub
End If
' Continue using vdrg e.g.:
Debug.Print vdrg.Address ' only the first <=257 characters of the address
'vdrg.Select
'vdrg.Copy Sheet2.Range("A2")
End Sub
Function SetMultiRangeRow( _
ByVal MultiRange As Range, _
ByVal MaxRowNumber As Long) _
As Range
Dim rCount As Long
rCount = MultiRange.Cells.CountLarge / MultiRange.Columns.Count
If rCount < MaxRowNumber Then Exit Function
Dim arg As Range
Dim rrg As Range
Dim r As Long
Dim lrrg As Range
For Each arg In MultiRange.Areas
For Each rrg In arg.Rows
r = r + 1
If r = MaxRowNumber Then
Set SetMultiRangeRow = rrg
Exit For
End If
Next rrg
Next arg
End Function