Question

我有以下代码。我试图执行的任务是：

包含＆＃39;是＆＃39;的行的过滤表在C栏
将单元格左侧的单元格复制到另一个位置（全部粘贴在一列中，每列都在新行上）
删除过滤器并将表单返回到预过滤状态

下面的代码会过滤列表，但会复制所有已过滤的表格。如何调整它以仅复制上述内容

谢谢！

Sub filter_me()

With Sheets("Trader")
    .Range("B8:B22").AutoFilter Field:=2, Criteria1:="yes"
    .AutoFilter.Range.Copy
  End With
With Sheets("SHEET2")
    .Range("B1").PasteSpecial
  End With
With Sheets("Trader")
     ActiveSheet.Range("B8:B22").AutoFilter
  End With
End Sub

Answer 1

Dim a as integer
Dim YesNoCol as Integer
Dim DataCol as Integer
Dim TargetCol as Integer

YesNoCol = 5
DataCol = 4
TargetCol = 8

' change rows as necessary
For a = 8 to 22
    If Ucase(ActiveSheet.Cells(a, YesNoCol).Value) = YES Then
        ActiveSheet.Cells(a, DataCol).Value = _
            ActiveSheet.Cells(a, TargetCol).Value
    End If
Next a

这样做适合你吗？对不起，我是通过记忆在手机上做到的。

Answer 2

如果需要，您可以尝试这样的方法并根据您的要求进行调整。

Sub filter_me()
Dim sws As Worksheet, dws As Worksheet
Application.ScreenUpdating = False
Set sws = Sheets("Trader")
Set dws = Sheets("Sheet2")
'Clearing Sheet2 before pasting the autofiltered data
dws.Cells.Clear

'Clearing existing filter on Trader sheet
sws.AutoFilterMode = False

'Assuming Row8 is header row
With sws.Rows(8)
    'filtering column C
    .AutoFilter field:=3, Criteria1:="yes"
    'checking if any data is returned after applying the autofilter
    If sws.Range("A8:A22").SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then
        'copying the filtered data from column A:B along with headers onto Sheet2 in B1
        sws.Range("A8:B22").SpecialCells(xlCellTypeVisible).Copy dws.Range("B1")
    End If
    .AutoFilter
End With
Application.ScreenUpdating = True
End Sub

Answer 3

这将按照以下方式为您完成：

Sub filter_me()

Dim wsTrader as Worksheet
Set wsTrader = Worksheets("Trader")

With wsTrader

    .Range("B8:B22").AutoFilter Field:=2, Criteria1:="yes"
    .Range("A8:A22").SpecialCells(xlCellTypeVisible).Copy 'copy filtered cells 1 column to left

   Worksheets("SHEET2").Range("B1").PasteSpecial xlPasteValues

    .Range("B8:B22").AutoFilter

End With

End Sub

Answer 4

如果您也要复制/粘贴标题;

Sub Main()
    With Worksheets("Trader").Range("C8:C22")
        .AutoFilter Field:=1 Criteria1:="yes"
        If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then .Offset(,-1).SpecialCells(xlCellTypeVisible).Copy Sheets("Sheet2").Range("B1")
        .Parent.AutoFilterMode = False
    End With
End Sub

同时如果要复制/粘贴没有标题行的过滤数据：

Sub Main()
    With Worksheets("Trader").Range("C8:C22")
        .AutoFilter Field:=1 Criteria1:="yes"
        If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then .Offset(1,-1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Sheets("Sheet2").Range("B1")
        .Parent.AutoFilterMode = False
    End With
End Sub

Answer 5

Sub copy()

Dim a As Integer
Dim YesNoCol As Integer
Dim DataCol As Integer
Dim TargetCol As Integer

YesNoCol = 3
DataCol = 2
TargetCol = 1

' change rows as necessary
For a = 8 To 22
If UCase(ActiveSheet.Cells(a, YesNoCol).Value) = YES Then
    ActiveSheet.Cells(a, DataCol).Value.copy
        ActiveSheet.Cells(a, TargetCol).Paste
End If
Next a

End Sub

VBA过滤表和复制单元格

5 个答案: