Excel 从筛选表的一列复制/粘贴/计算可见单元格

我正在使用

AutoFilter

对VBA中的一个表进行排序，从而生成一个较小的数据表。我只想在应用过滤器后复制/粘贴一列的可见单元格。另外，我想平均一列的过滤值，并将结果放在另一个单元格中

我在堆栈上发现了这个代码段，它允许我复制/粘贴过滤器的整个可见结果，但我不知道如何修改它，也不知道如何从中仅获取一列数据（不带标题）

添加到答案（使用过滤值计算）：

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

---

我在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

是不必要的。

如果您需要更进一步，只需添加到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的评论，所以我不得不以新评论的形式发布，对不起

我发现这很有效。它使用.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

---

下面是一段适用于windowsoffice 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

---

享受吧

如果要平均筛选范围的一部分，请使用以下命令：

Application.WorksheetFunction.average（copyRange.SpecialCells（xlCellTypeVisible））

。（回应现已删除的评论）

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