Selection.AutoFilter Field:=1, Criteria1:="*" & Cells(1, 1) & "*", Operator:=xlAnd

Sub Макрос1()
    Dim filterValuesRn  As Range, RangeToAutofilterRn As Range, filterArr() As String, i As Long
    ' Диапазон 2 (значения в фильтр)
    Set filterValuesRn = ThisWorkbook.Sheets(3).Range("A1:A150")
    ' Диапазон 1 (что фильтруем)
    Set RangeToAutofilterRn = ThisWorkbook.Sheets(4).Range("F1:F70000")
     
    ' Массив со значениями для фильтрациии
    ' Заполняем из диапазона 2
    ReDim filterArr(0 To filterValuesRn.Cells.Count - 1)
    For i = 0 To filterValuesRn.Cells.Count - 1
        filterArr(i) = filterValuesRn.Cells(i + 1)
    Next i
     
    ' Если на листе с диапазоном 1 уже есть автофильтр - сначала снимем все текущие фильтры
    If RangeToAutofilterRn.Parent.AutoFilterMode = True Then RangeToAutofilterRn.Parent.AutoFilter.ShowAllData
    ' Применим фильтр
    RangeToAutofilterRn.AutoFilter Field:=1, Criteria1:=filterArr, Operator:=xlFilterValues
End Sub

Sub Ìàêðîñ1()
    ActiveSheet.Range("$D$2:$I$51586").AutoFilter Field:=3, Criteria1:=Array( _
        ActiveWorkbook.Worksheets("Ëèñò3").Range("$D$2:$I$51586")), Operator:=xlFilterValues
End Sub

Sub DELETE()
For Each sh In ActiveWorkbook.Worksheets
Dim AllRows As Object, FirstCell As Object, FoundCell As Object
 
    sh.Application.ScreenUpdating = False
 
    Set FirstCell = Columns("F:G").Find(what:=0, LookAt:=xlWhole)
    If FirstCell Is Nothing Then Exit Sub
 
    Set AllRows = Rows(FirstCell.Row)
    Set FoundCell = FirstCell
 
    Do
        Set FoundCell = Columns("F:G").FindNext(After:=FoundCell)
        Set AllRows = Union(Rows(FoundCell.Row), AllRows)
        If FoundCell.Address = FirstCell.Address Then Exit Do
    Loop
    AllRows.UnMerge
        AllRows.Clear
        Next
End Sub

Sub DELETE()

Dim AllRows As Object, FirstCell As Object, FoundCell As Object

    Application.ScreenUpdating = False

    Set FirstCell = Columns("F:G").Find(what:=0, LookAt:=xlWhole)
    If FirstCell Is Nothing Then Exit Sub

    Set AllRows = Rows(FirstCell.Row)
    Set FoundCell = FirstCell

    Do
        Set FoundCell = Columns("F:G").FindNext(After:=FoundCell)
        Set AllRows = Union(Rows(FoundCell.Row), AllRows)
        If FoundCell.Address = FirstCell.Address Then Exit Do
    Loop
    AllRows.Clear
End Sub

Sub DELETE()

Dim AllRows As Object, FirstCell As Object, FoundCell As Object

    Application.ScreenUpdating = False

    Set FirstCell = Columns("F:G").Find(what:=0, LookAt:=xlWhole)
    If FirstCell Is Nothing Then Exit Sub

    Set AllRows = Rows(FirstCell.Row)
    Set FoundCell = FirstCell

    Do
        Set FoundCell = Columns("F:G").FindNext(After:=FoundCell)
        Set AllRows = Union(Rows(FoundCell.Row), AllRows)
        If FoundCell.Address = FirstCell.Address Then Exit Do
    Loop
    AllRows.DELETE
End Sub

Sub delzero()
For Each ws In ActiveWorkbook.Worksheets
ws.Columns("F:G").Replace What:="0", Replacement:="", LookAt:=xlWhole
Next
End Sub

Sub DelFormula()
For Each sh In ActiveWorkbook.Sheets
 sh.UsedRange.Value = sh.UsedRange.Value
Next
End Sub

Sub Del_zero()
Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        ws.Replace What:="0", Replacement:="", LookAt:=xlWhole
    Next
End Sub

Sub Удалить_нули()   
   Columns("A:B").Replace What:="0", Replacement:="", LookAt:=xlWhole   
End Sub

Sub zx()
Dim a, fzx As Worksheet
Dim aa, ff As Long
 
Set a = Sheets("Лист3")
Set fzx = Sheets("Движение заказов")
aa = a.Cells(Rows.Count, 1).End(xlUp).Row
ff = fzx.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
    For i = 2 To ff
    For j = 1 To aa
    If fzx.Cells(i, 2).Value = a.Cells(j, 1).Value Then
    a.Cells(j, 1).Copy
    fzx.Cells(i, 2).PasteSpecial Paste:=xlPasteComments
    End If
    Next j, i
    Application.ScreenUpdating = True
End Sub

aa = a.Cells(Rows.Count, 1).End(xlUp).Row
bb = bzx.Cells(Rows.Count, 1).End(xlUp).Row