VBA 过滤表和复制单元格答案

【问题标题】：VBA filter table and copy cellsVBA 过滤表和复制单元格
【发布时间】：2017-04-04 18:25:40
【问题描述】：

我有下面的代码。我正在尝试执行的任务是：

为 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

【问题讨论】：

标签： vba excel

【解决方案1】：

这将为您完成所写的：

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

【讨论】：

【解决方案2】：

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

这对你有用吗？抱歉，我是凭记忆在手机上做的。

【讨论】：

嗨，这些似乎都不起作用。我已将代码调整为以下，但仍然无法复制和粘贴

【解决方案3】：

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

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

【讨论】：

【解决方案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

【讨论】：

@gekko2670，你通过了吗？

【解决方案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

【讨论】：