Question

我对VBA非常陌生。我正在从工作表sheet1中获取很少的数据，并将已过滤的数据移至工作表sheet2。该标准适用于该“ <1st shift”以外的其他过滤器数据请你能帮忙。我正在使用此代码。

Sub copypaste() 
    Sheets("Sheet1").Activate
    Range("B2", Range("B2").End(xlDown).End(xlToRight)).Select
    Selection.AutoFilter Field:=8, Criteria1:="<1st Shift”
    Selection.Copy

    Worksheets("Sheet2").Activate
    Range("B7").PasteSpecial
End Sub

Answer 1

我已经测试了以下内容，并且对我有用。我更改了您使用的代码，以确保仅在符合条件的行中复制行。

要记住的另一件事是避免使用.Activate和.Select，因为它们只会减慢您的代码的速度，请查看下面的修改后的代码：

Sub copypaste()
Dim ws1 As Worksheet: Set ws1 = Worksheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")
Dim Rng As Range, LastRow As Long
'declare and set the worksheets you are working with, amend as required
ws1.Cells.AutoFilter Field:=8, Criteria1:="<1st Shift"
'filter Sheet1 Column H with criteria
Set Rng = ws1.Range("B2", Range("B2").End(xlDown).End(xlToRight)).SpecialCells(xlCellTypeVisible)
'set the range to be copied, only looking at the visible rows
LastRow = ws1.Range("B1").End(xlDown).Row
'check the last row with data on Column B
If LastRow <> ws1.Rows.Count Then
'check if there are any rows that match the criteria
    Rng.Copy
    'copy the range
    ws2.Range("B7").PasteSpecial xlPasteAll
    'paste into Sheet2 cell B7
Else
    MsgBox "Criteria not found", vbInformation, "Error"
End If
ws1.Cells.AutoFilter
'remove the AutoFilter
End Sub

更新：

如果您有多个条件，则可以使用以下代码：

Sub copypaste()
Dim ws1 As Worksheet: Set ws1 = Worksheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")
Dim Rng As Range, LastRow As Long
'declare and set the worksheets you are working with, amend as required
ws1.Cells.AutoFilter Field:=8, Criteria1:="5", Operator:=xlOr, Criteria2:="<1st Shift"
'filter Sheet1 Column H with criteria
Set Rng = ws1.Range("B2", Range("B2").End(xlDown).End(xlToRight)).SpecialCells(xlCellTypeVisible)
'set the range to be copied, only looking at the visible rows
LastRow = ws1.Range("B1").End(xlDown).Row
'check the last row with data on Column B
If LastRow <> ws1.Rows.Count Then
'check if there are any rows that match the criteria
    Rng.Copy
    'copy the range
    ws2.Range("B7").PasteSpecial xlPasteAll
    'paste into Sheet2 cell B7
Else
    MsgBox "Criteria not found", vbInformation, "Error"
End If
ws1.Cells.AutoFilter
'remove the AutoFilter
End Sub

从一张纸到另一张纸的VBA自动过滤器

1 个答案: