如何使用 VBA 将过滤后的单元格复制到新工作表答案

【问题标题】：How to copy filtered cells to a new worksheet using VBA如何使用 VBA 将过滤后的单元格复制到新工作表
【发布时间】：2015-05-15 03:02:29
【问题描述】：

我有这段代码可以自动过滤我需要的数据并将其导出到新工作簿。但是，我需要将其导出到同一工作簿中的新工作表中。有什么办法可以解决这个问题吗？我目前正在使用此代码：

Sub TestFilter()
Range("D1").AutoFilter Field:=4, Criteria1:="In Scope"
Range("M1").AutoFilter Field:=13, Criteria1:="NOT ASSIGNED"
Range("AG1").AutoFilter Field:=33, Criteria1:="Opening"
ActiveSheet.AutoFilter.Range.Copy
Workbooks.Add.Worksheets(1).Paste
Cells.AutoFilter
End Sub

谢谢！

【问题讨论】：

标签： vba excel

【解决方案1】：

类似这样的东西（您应该在其中编辑您正在过滤的范围）

Sub TestFilter()

Dim ws As Worksheet
Dim ws2 As Worksheet

Set ws = ActiveSheet
ws.AutoFilterMode = False

With ws.Range("A1:AZ100")
    .AutoFilter 4, "In Scope"
    .AutoFilter 13, "NOT ASSIGNED"
    .AutoFilter 33, "Opening"
End With
ws.AutoFilter.Range.Copy
Set ws2 = Sheets.Add(, , Sheets.Count)
ws2.Paste

ws.AutoFilterMode = False
Application.CutCopyMode = False

End Sub

【讨论】：

简单而有效:)

【解决方案2】：

您可以尝试这样的事情（Excel 2013）：

Sub Macro1()

    ' set up auto-filter for testing
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$AG$3000").AutoFilter Field:=1, Criteria1:="John"   ' firstname
    ActiveSheet.Range("$A$1:$AG$3000").AutoFilter Field:=2, Criteria2:="Smith"  ' lastname

    ' copy filtered data by doing CTRL + right-arrow and then CTRL + down arrow
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy

    ' add a sheet after the existing one and paste values
    Sheets.Add After:=ActiveSheet
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

End Sub

【讨论】：

【解决方案3】：

我基于以下假设（与提供的代码一致）提出以下代码：

包含源数据的工作表处于活动状态
数据源已被过滤，否则在提供的代码中应用的过滤器将不适用于所有情况。

如果不是这种情况，我们需要识别和过滤源数据，以下也适用：

数据源从单元格 A1 开始（根据第一个过滤器：Range("D1").AutoFilter Field:=4）
数据源至少进入第 33 列（根据第三个过滤器：Range("AG1").AutoFilter Field:=33）

代码

Option Explicit

Sub Wsh_CopyFilteredSourceDataToNewWorksheet()
Rem Define variables to work with the Worksheets and Range
Const kColLast = 33
Dim WshSrc As Worksheet
Dim WshTrg As Worksheet
Dim RngSrc As Range

    Set WshSrc = ActiveSheet
    Set WshTrg = WshSrc.Parent.Sheets.Add(After:=WshSrc)

    Rem (1) Set AutoFilter for SourceData starting at "A1"
    With WshSrc
        Rem Reset AutoFilter for Source Worksheet
        If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter
        If .UsedRange.SpecialCells(xlLastCell).Column < kColLast Then
            .Cells(1, kColLast).Value = "Fld." & kColLast
            .Range(.Cells(1), .Cells(.UsedRange.SpecialCells(xlLastCell).Row, kColLast)).AutoFilter
        Else
            .Range(.Cells(1), .UsedRange.SpecialCells(xlLastCell)).AutoFilter
        End If

        Rem Set Filters
        With .AutoFilter.Range
            .AutoFilter Field:=4, Criteria1:="In Scope"
            .AutoFilter Field:=13, Criteria1:="NOT ASSIGNED"
            .AutoFilter Field:=33, Criteria1:="Opening"
    End With: End With

    Rem Copy Filtered Source Data to New Worksheet
    Set RngSrc = WshSrc.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
    With WshTrg.Cells(1)
        RngSrc.Copy
        Rem As per code provided
        .PasteSpecial
        Rem Since we are copying only partial worksheet data I suggest to use the following
        .PasteSpecial xlPasteFormulasAndNumberFormats
        Rem Always Reset CutCopyMode
        Application.CutCopyMode = False
    End With
    WshTrg.UsedRange.Columns.AutoFit

End Sub

【讨论】：