我有几个excel表格，表格的格式与下面类似:
我要复制的所有行，其中的数字在&;value &;;
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
Copy By Criteria
- 调整常量部分的值
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