从过滤表的一列复制/粘贴/计算可见单元格

Posted 2023-02-27

【中文标题】从过滤表的一列复制/粘贴/计算可见单元格

【英文标题】：Copy/Paste/Calculate Visible Cells from One Column of a Filtered Table

【发布时间】：2013-07-06 01:12:41

【问题描述】：

我正在使用AutoFilter 对 VBA 中的表进行排序，这会产生更小的数据表。我只想在应用过滤器后复制/粘贴一列的可见单元格。另外，我想平均一列的过滤值并将结果放在不同的单元格中。

我在 Stack 上找到了这个 sn-p，它允许我复制/粘贴过滤器的整个可见结果，但我不知道如何修改它或以其他方式仅获取一列的数据（没有标题）。

Range("A1",Cells(65536,Cells(1,256).End(xlToLeft).Column).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
Sheets("Sheet2").Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False

添加答案（使用过滤后的值进行计算）：

tgt.Range("B2").Value =WorksheetFunction.Average(copyRange.SpecialCells(xlCellTypeVisible))

【参考方案1】：

我在 Sheet1 上设置了一个简单的 3 列范围，在 A、B 和 C 列中包含国家、城市和语言。以下代码自动过滤该范围，然后仅将自动过滤数据的一列粘贴到另一张工作表中.您应该可以根据自己的目的进行修改：

Sub CopyPartOfFilteredRange()
    Dim src As Worksheet
    Dim tgt As Worksheet
    Dim filterRange As Range
    Dim copyRange As Range
    Dim lastRow As Long

    Set src = ThisWorkbook.Sheets("Sheet1")
    Set tgt = ThisWorkbook.Sheets("Sheet2")

    ' turn off any autofilters that are already set
    src.AutoFilterMode = False

    ' find the last row with data in column A
    lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row

    ' the range that we are auto-filtering (all columns)
    Set filterRange = src.Range("A1:C" & lastRow)

    ' the range we want to copy (only columns we want to copy)
    ' in this case we are copying country from column A
    ' we set the range to start in row 2 to prevent copying the header
    Set copyRange = src.Range("A2:A" & lastRow)

    ' filter range based on column B
    filterRange.AutoFilter field:=2, Criteria1:="Rio de Janeiro"

    ' copy the visible cells to our target range
    ' note that you can easily find the last populated row on this sheet
    ' if you don't want to over-write your previous results
    copyRange.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A1")

End Sub

请注意，通过使用上述语法进行复制和粘贴，不会选择或激活任何内容（在 Excel VBA 中应始终避免这样做），并且不会使用剪贴板。因此，Application.CutCopyMode = False 是不必要的。

【讨论】：

如果您想对过滤范围的一部分进行平均，请使用：Application.WorksheetFunction.Average(copyRange.SpecialCells(xlCellTypeVisible))。 （回应现已删除的评论）

【参考方案2】：

如果您需要更进一步，只需添加到 Jon 的编码中，并且做的不仅仅是一列，您还可以添加类似

的内容

Dim copyRange2 As Range
Dim copyRange3 As Range

Set copyRange2 =src.Range("B2:B" & lastRow)
Set copyRange3 =src.Range("C2:C" & lastRow)

copyRange2.SpecialCells(xlCellTypeVisible).Copy tgt.Range("B12")
copyRange3.SpecialCells(xlCellTypeVisible).Copy tgt.Range("C12")

将它们放在其他相同的编码附近，您可以根据需要轻松更改范围。

我添加这个只是因为它对我有帮助。我假设 Jon 已经知道这一点，但对于那些经验不足的人来说，有时了解如何更改/添加/修改这些编码会很有帮助。我认为，由于 Ruya 不知道如何操作原始编码，因此如果只需要复制 2 个可见列或仅 3 个等，它可能会有所帮助。您可以使用相同的编码，添加几乎相同，然后编码将复制您需要的任何内容。

我没有足够的声誉直接回复 Jon 的评论，所以我必须作为新评论发布，抱歉。

【参考方案3】：

我发现这很好用。它使用 .autofilter 对象的 .range 属性，这似乎是一个相当晦涩但非常方便的功能：

Sub copyfiltered()
    ' Copies the visible columns
    ' and the selected rows in an autofilter
    '
    ' Assumes that the filter was previously applied
    '
    Dim wsIn As Worksheet
    Dim wsOut As Worksheet

    Set wsIn = Worksheets("Sheet1")
    Set wsOut = Worksheets("Sheet2")

    ' Hide the columns you don't want to copy
    wsIn.Range("B:B,D:D").EntireColumn.Hidden = True

    'Copy the filtered rows from wsIn and and paste in wsOut
    wsIn.AutoFilter.Range.Copy Destination:=wsOut.Range("A1")
End Sub

【参考方案4】：

这是适用于 windows office 2010 的代码。此脚本将要求您输入过滤的单元格范围，然后是粘贴范围。

请，两个范围应该有相同数量的单元格。

Sub Copy_Filtered_Cells()

Dim from As Variant
Dim too As Variant
Dim thing As Variant
Dim cell As Range

'Selection.SpecialCells(xlCellTypeVisible).Select

    'Set from = Selection.SpecialCells(xlCellTypeVisible)
    Set temp = Application.InputBox("Copy Range :", Type:=8)
    Set from = temp.SpecialCells(xlCellTypeVisible)
    Set too = Application.InputBox("Select Paste range selected cells ( Visible cells only)", Type:=8)



    For Each cell In from
        cell.Copy
        For Each thing In too
            If thing.EntireRow.RowHeight > 0 Then
                thing.PasteSpecial
                Set too = thing.Offset(1).Resize(too.Rows.Count)
                Exit For
            End If
        Next
    Next


End Sub

享受吧！