Блог

У меня есть несколько листов Excel с таблицами аналогичного формата, как показано ниже:

Где я хотел бы скопировать все строки, в которых число в заголовке «Значение» превышает 10, на пустую вкладку.

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

End Sub
 

После этого я хотел бы выбрать все значения, отфильтрованные здесь, и скопировать их на чистый лист. Далее я хотел бы повторить весь процесс, но скопировать строки на основе другого заголовка/критериев во вторую пустую вкладку.

Спасибо!

Вы можете сделать что-то вроде этого:

 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
 

Копирование По Критериям

• Отрегулируйте значения в разделе константы.

 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 "'" amp; ProcName amp; "': Unexpected Error!" amp; vbLf _
              amp; "    " amp; "Run-time error '" amp; Err.Number amp; "':" amp; vbLf _
              amp; "    " amp; 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