Автофильтр VBA с одного листа на другой

Question

Я очень новичок в VBA. Я смотрю на получение нескольких данных из листа1 с отфильтрованными данными для перемещения на лист2. Критерий работает для других данных фильтра, кроме этой «<1-я смена» Пожалуйста, не могли бы вы помочь. Я использую этот код. </p>

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

UPDATE:

В случае, когда у вас есть несколько критериев, вы можете использовать следующий код:

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