选择前 800 个可见单元格仅形成一列，即使有超过 800 个可见过滤单元格也是如此

Question

我需要一个VBA代码，它将允许我仅选择和复制自定义数量的可见行。 例如：我过滤了列数据，所有可见单元格的计数为 1000。但是，我只想从 800 个可见单元格中复制前 1000 个可见单元格。

Answer 1

一个想法是使用SpecialCells(xlCellTypeVisible)获取所有可见单元格，然后循环并使用Application.Union逐个收集它们，以将它们限制在您想要的数量。

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

如果要将其用作公式中的UDF(用户定义函数)，则已知SpecialCells(xlCellTypeVisible)在那里失败(请参阅SpecialCells(xlCellTypeVisible)在UDF中不起作用)。您需要自己检查可见性：

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

复制前n行SpecialCells(xlCellTypeVisible)

• 这通常是对更多列完成的，如代码中所示。

• 要仅将其应用于第A列，请将Set rg = ws.Range("A1").CurrentRegion替换为

  Set rg = ws.Range("A1").CurrentRegion.Columns(1)
  

  假设标题位于工作表的第一行中。

• 简而言之，它遍历范围(MultiRange，dvrg)的每个区域(arg)的行(rrg)，计算每一行(r)，当它点击"标记"(DataRowsCount)时，它使用这一行(Set SetMultiRangeRow = rrg，lrrg)和第一行(frrg)作为range属性中的参数来设置所需的范围并重新应用相同类型的SpecialCells以最终引用所需的数量行。

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