VBAfilter表和复制单元格

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

1. 筛选C列中包含“是”的行的表
2. 将单元格复制到每个“是”的左侧到另一个位置（全部粘贴在一列中，每个都放在新行中）
3. 删除filter并将工作表返回到预过滤状态

下面的代码过滤列表，但是然后复制所有已过滤的表。 我怎样才能调整它只复制上面所述的内容

谢谢！

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