Sub Снять_фильтр()
On Error GoTo m
ActiveSheet.ShowAllData
Exit Sub
m:
MsgBox "Фильтра не установлены"
End Sub

Sub ProtectionProcedure()
    With ThisWorkbook
        .Worksheets("1111").Protect Password:="1111", UserInterfaceOnly:=True
    End With
End Sub

Function VLOOKUPCOUPLE(Table As Variant, _

                        SearchColumnNum As Integer, _

                        SearchValue As Variant, _

                        RezultColumnNum As Integer, _

                        Separator_ As String, _

                        Optional BezPovtorov As Boolean = True)

                          

'Table - таблица, где ищем

'SearchColumnNum - столбец, где ищем

'SearchValue - данные, которые ищем

'RezultColumnNum - столбец, откуда берём результат

'Separator_ - разделитель, желательно вводить с пробелом в конце

'BezPovtorov - если поставить 0, то будут выведены все повторяющиеся совпадения

  

    Dim i As Long, tmp As String, vlk

  

    If TypeName(Table) = "Range" Then Table = Intersect(Table.Parent.UsedRange, Table).Value

    If BezPovtorov Then

        With CreateObject("Scripting.Dictionary")

            For i = 1 To UBound(Table)

                If Table(i, SearchColumnNum) = SearchValue Then

                    tmp = Table(i, RezultColumnNum)

                    If tmp <> "" Then

                        If Not .Exists(tmp) Then

                            .Add tmp, 0&

                            vlk = vlk & Separator_ & Table(i, RezultColumnNum)

                        End If

                    End If

                End If

            Next i

        End With

    Else

        For i = 1 To UBound(Table)

            If Table(i, SearchColumnNum) = SearchValue Then

                vlk = vlk & Separator_ & Table(i, RezultColumnNum)

            End If

        Next i

    End If

    If vlk > 0 Then vlk = Mid(vlk, Len(Separator_) + 1) Else vlk = ""

    VLOOKUPCOUPLE = vlk

End Function