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.

CodePudding user response：

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

CodePudding user response：

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.FilterMode Then ws.ShowAllData ' clear filters
    
    ' 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