使用 VBA 将过滤的行复制到另一个工作表中

Question

我有几个 Excel 表格，表格的格式与以下类似：

我想将“值”标题下的数字超过 10 的所有行复制到空白选项卡中。

Sub Copy_Criteria()
    
With Range("A5:P1000")
.AutoFilter Field:=15, Criteria1:=">10"
End With

End Sub

之后，我想选择此处过滤的所有值并将它们复制到一张空白表中。 接下来，我想重复整个过程，但将基于另一个标题/标准的行复制到第二个空白选项卡中。

谢谢！

Answer 1

你可以这样做：

With Range("A5:P1000")
    .AutoFilter Field:=15, Criteria1:=">30"
    On Error Resume Next  'in case no visible cells
    .SpecialCells(xlCellTypeVisible).Copy Sheet2.Range("a1")
    On Error Goto 0
    .Parent.ShowAllData 'clear filter
End With

Answer 2

按标准复制

• 调整常量部分中的值。

Option Explicit

Sub CopyByCriteria()
' Needs 'RefCurrentRegionBottomRight', 'GetFilteredRange' and 'GetRange'.
    Const ProcTitle As String = "CopyByCriteria"
        
    Const sFirst As String = "A5"
    Dim swsNames As Variant: swsNames = Array("Sheet1", "Sheet2", "Sheet3")
        
    Const dFirst As String = "A1"
    ' These three arrays need to have the same number of elements.
    Dim dwsNames As Variant: dwsNames = Array("15gt10", "12gt15")
    Dim dFields As Variant: dFields = Array(15, 12)
    Dim dCriteria As Variant: dCriteria = Array(">10", ">15")
        
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet
    Dim srg As Range
    Dim dws As Worksheet
    Dim drg As Range
    Dim dCell As Range
    Dim dData As Variant
    Dim n As Long
    Dim IncludeHeaders As Boolean
    
    For n = LBound(dwsNames) To UBound(dwsNames)
        
        On Error Resume Next
            Application.DisplayAlerts = False
                wb.Sheets(dwsNames(n)).Delete
            Application.DisplayAlerts = True
        On Error GoTo 0
        
        Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
        dws.Name = dwsNames(n)
        Set dCell = dws.Range(dFirst)
        
        IncludeHeaders = True
        
        For Each sws In wb.Worksheets(swsNames)
            
            Set srg = RefCurrentRegionBottomRight(sws.Range(sFirst))
            dData = GetFilteredRange( _
                srg, dFields(n), dCriteria(n), IncludeHeaders, IncludeHeaders)
            
            If Not IsEmpty(dData) Then
                IncludeHeaders = False ' include only the first time
                Set drg = dCell.Resize(UBound(dData, 1), UBound(dData, 2))
                drg.Value = dData
                Set dCell = dCell.Offset(UBound(dData, 1))
            End If
        
        Next sws
    
    Next n
        
    MsgBox "Worksheets created. Values copied.", vbInformation, ProcTitle

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the filtered values of a range ('rg')
'               in a 2D one-based array.
' Remarks:      If ˙rg` refers to a multi-range, only its first area
'               is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetFilteredRange( _
    ByVal rg As Range, _
    ByVal fField As Long, _
    ByVal fCriteria As String, _
    Optional ByVal IncludeHeaders As Boolean = True, _
    Optional ByVal AllowHeadersOnly As Boolean = False) _
As Variant
' Needs the 'GetRange' function.
    Const ProcName As String = "GetFilteredRange"
    On Error GoTo ClearError
    
    Dim ws As Worksheet: Set ws = rg.Worksheet
    If ws.AutoFilterMode Then
        ws.AutoFilterMode = False
    End If

    rg.AutoFilter fField, fCriteria
    
    Dim frShift As Long: frShift = IIf(IncludeHeaders, 0, 1)
    
    Dim frg As Range
    On Error Resume Next
        Set frg = rg.Resize(rg.Rows.Count - frShift) _
            .Offset(frShift).SpecialCells(xlCellTypeVisible)
    On Error GoTo ClearError
    ws.AutoFilterMode = False
    
    If Not frg Is Nothing Then
        Dim frCount As Long
        frCount = Intersect(frg, ws.Columns(frg.Column)).Cells.Count
        Dim doContinue As Boolean: doContinue = True
        
        If frShift = 0 Then
            If frCount = 1 Then
                If Not AllowHeadersOnly Then
                    doContinue = False
                End If
            End If
        End If
        
        If doContinue Then
            Dim fcCount As Long: fcCount = frg.Columns.Count
            
            Dim dData As Variant: ReDim dData(1 To frCount, 1 To fcCount)
            Dim tData As Variant
            
            Dim arg As Range
            Dim ar As Long
            Dim c As Long
            Dim dr As Long
            Dim trCount As Long
            
            For Each arg In frg.Areas
                tData = GetRange(arg)
                For ar = 1 To arg.Rows.Count
                    dr = dr + 1
                    For c = 1 To fcCount
                        dData(dr, c) = tData(ar, c)
                    Next c
                Next ar
            Next arg
        
            GetFilteredRange = dData
        'Else ' frShift = 0: frCount = 1: AllowHeadersOnly = False
        End If
        
    'Else ' no filtered range
    End If

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a range ('rg') in a 2D one-based array.
' Remarks:      If ˙rg` refers to a multi-range, only its first area
'               is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
    ByVal rg As Range) _
As Variant
    If rg Is Nothing Then Exit Function
    
    If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
        Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
        GetRange = Data
    Else ' multiple cells
        GetRange = rg.Value
    End If

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a reference to the range starting with a given cell
'               and ending with the last cell of its Current Region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegionBottomRight( _
    ByVal FirstCellRange As Range) _
As Range
    If FirstCellRange Is Nothing Then Exit Function
    With FirstCellRange.Cells(1).CurrentRegion
        Set RefCurrentRegionBottomRight = _
            FirstCellRange.Resize(.Row + .Rows.Count - FirstCellRange.Row, _
            .Column + .Columns.Count - FirstCellRange.Column)
    End With
End Function