Set ra = Лист1.Range("A2:A100") 'Range([A2], Range("A" & Rows.Count).End(IIf(Len(Range("A" & Rows.Count)), xlDown, xlUp)))

Private Sub CommandButton1_Click()
    
    Dim ws As Object, ra As Range, cc As Range
    Dim iLastrow As Long

    Set ws = Лист1
    Set ra = Лист1.Range("A2:A100") 'Range([A2], Range("A" & Rows.Count).End(IIf(Len(Range("A" & Rows.Count)), xlDown, xlUp)))
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    With Лист2
        iLastrow = .Range("A" & Rows.Count).End(IIf(Len(.Range("A" & Rows.Count)), xlDown, xlUp)).Row

        For Each cc In ra
            If cc = Me.ComboBox1.Text Then
                If InStr(cc.Offset(, 4), Me.ComboBox2.Text) > 0 Then
                    If InStr(cc.Offset(, 5), Me.ComboBox3.Text) > 0 Then
                        If InStr(cc.Offset(, 7), Me.ComboBox4.Text) > 0 Then
                            iLastrow = iLastrow + 1
                            ws.Rows(cc.Row).Copy .Cells(iLastrow, 1)
                        End If
                    End If
                End If
            End If
        Next
    End With
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

Private Sub CommandButton1_Click()
    Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 2) = _
        Array(Val(Me.TextBox1), Me.TextBox2)
End Sub

Sub Save12()
Application.ScreenUpdating = False
Application.ActivePrinter = Sheets("Списки").[P3].Value 'принтер для сохранения в PDF
Sheets("Таблица").Calculate

Dim x

  x = Application.GetSaveAsFilename(ThisWorkbook.Path & "\" & Sheets("Таблица").[E8].Value, "PDF files (*.pdf), *.pdf") 'путь и имя файла
  If x <> False Then
    Sheets("12").ExportAsFixedFormat Type:=xlTypePDF, Filename:=x _
      , Quality:=xlQualityStandard, IncludeDocProperties:=True _
      , IgnorePrintAreas:=False, OpenAfterPublish:=False
      Else
      Exit Sub
  End If
  
Application.ActivePrinter = Sheets("Списки").[P4].Value 'принтер по умолчанию
Call Vedomost_FIO
Application.ScreenUpdating = True
End Sub

' Written:  August 05, 2017
' Authoer:  Leith Ross
' Summary:  Returns and array of printer names and port numbers on the user's computer.
'           The API calls in this module will work with both 64 bit and 32 bit Office running Windows 7 and higher.

Private Declare PtrSafe Function RegOpenKeyEx _
    Lib "Advapi32.dll" Alias "RegOpenKeyExA" _
        (ByVal hKey As LongPtr, _
         ByVal lpctstrSubKey As String, _
         ByVal ulOptions As Long, _
         ByVal samDesired As Long, _
         ByRef phKey As LongPtr) _
    As Long

Private Declare PtrSafe Function RegEnumValue _
    Lib "Advapi32.dll" Alias "RegEnumValueA" _
        (ByVal hKey As LongPtr, _
         ByVal dwIndex As Long, _
         ByVal lptstrValueName As String, _
         ByRef lpcchValueName As Long, _
         ByVal lpReserved As Long, _
         ByRef lpType As Long, _
         ByRef lpData As Byte, _
         ByRef lpcbData As Long) _
    As Long
    
Private Declare PtrSafe Function RegCloseKey _
    Lib "Advapi32.dll" _
        (ByVal hKey As LongPtr) _
    As Long
    
Private Declare PtrSafe Function FormatMessage _
    Lib "kernel32.dll" Alias "FormatMessageA" _
        (ByVal dwFlags As Long, _
         ByVal lpSource As Long, _
         ByVal dwMessageId As Long, _
         ByVal dwLanguageId As Long, _
         ByVal lptstrBuffer As String, _
         ByVal nSize As Long, _
         ByVal vaArguments As Any) _
    As Long
    
Sub DisplayError(ByVal Title As String, ByVal ErrorNumber As Long)
    
    Dim errMessage  As String
    Dim lenMessage  As Integer
    Dim msg         As String
    Dim retval      As Long
    
    Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
    
        lenMessage = 260
        errMessage = String(lenMessage, Chr(0))
        
        retval = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0&, ErrorNumber, 0&, errMessage, lenMessage, 0&)
        If retval > 0 Then
            msg = "Run-time error '" & ErrorNumber & "':" & vbLf & vbLf
            msg = msg & Left(errMessage, retval)
            MsgBox msg, vbExclamation + vbOKOnly, Title
        End If
        
End Sub

Function GetPrintersAndPorts() As Variant

    Dim Data()  As Byte
    Dim datType As Long
    Dim hKey    As LongPtr
    Dim index   As Long
    Dim lenData As Long
    Dim lenName As Long
    Dim prnData As Variant
    Dim prnName As String
    Dim prnPort As Variant
    Dim retval  As Long
    Dim strEnd  As Long
    Dim SubKey  As String
    Dim Text    As String
    Dim valName As String
    
    Const HKCU                  As Long = &H80000001
    Const KEY_READ              As Long = &H20019
    Const SUCCESS               As Long = 0
    Const ERROR_MORE_DATA       As Long = 234
    Const ERROR_NO_MORE_ITEMS   As Long = 259
        
        ReDim prnData(0)
        
        SubKey = "Software\Microsoft\Windows NT\CurrentVersion\PrinterPorts"

            retval = RegOpenKeyEx(HKCU, SubKey, 0&, KEY_READ, hKey)
            If retval <> 0 Then Call DisplayError("Cannot Open Registry Key", retval): Exit Function
        
            Do
Start:          ReDim Data(65535)
                lenName = 260
                valName = String(lenName, Chr(0))
                retval = RegEnumValue(hKey, index, valName, lenName, 0&, datType, Data(0), lenData)
                    Select Case retval
                        Case SUCCESS
                        Case ERROR_MORE_DATA: If Data(0) = 0 Then GoTo Start
                        Case ERROR_NO_MORE_ITEMS: Exit Do
                        Case Else: Call DisplayError("Printer Port Registry Error", retval): Exit Do
                    End Select
                index = index + 1
                
                Text = StrConv(Data, vbUnicode)
                strEnd = InStr(1, Text, Chr(0) & Chr(0)) - 1
                If strEnd > 0 Then
                    prnName = Left(valName, lenName)
                    prnPort = Split(Text, ",")(1)
                    prnData(index - 1) = prnName & " on " & prnPort
                    ReDim Preserve prnData(index)
                End If
            Loop
        
        retval = RegCloseKey(hKey)
        
        If retval <> SUCCESS Then
            Call DisplayError("Cannot Close Registry Key", retval)
        Else
            GetPrintersAndPorts = prnData
        End If
        
End Function

Function FindPrinter(ByVal PrinterName As String)

    Dim Printer  As Variant
    Dim Printers As Variant
    
        ' The asterisk "*" in place of a printer name returns All Printers.
        ' Partially matching printers names are separated by a pipe character "|".
        
        Printers = GetPrintersAndPorts
    
        For Each Printer In Printers
            If PrinterName <> "*" Then
                Res = Application.Search(PrinterName, Printer)
            Else
                Res = -1
            End If
            If VarType(Res) <> vbError Then
                If FindPrinter = "" Then
                    FindPrinter = Printer
                Else
                    FindPrinter = FindPrinter & "|" & Printer
                End If
            End If
        Next Printer
        
End Function

Sub FindPrinterTest()

    Dim Printers As Variant
    
        Printers = FindPrinter("")
        MsgBox Replace(Printers, "|", vbLf)
        
End Sub

Private Declare Function GetProfileString Lib "kernel32" _
Alias "GetProfileStringA" (ByVal lpAppName As String, _
ByVal lpKeyName As String, ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long) As Long

Dim vaList

Sub Print_Select()
    On Error Resume Next
    Application.ScreenUpdating = False
    Dim prncnt As Integer
    vaList = PrinterFind
    For prncnt = LBound(vaList) To UBound(vaList) ' èùåì ïðèíòåðû
        PrintForm.ComboBox1.AddItem vaList(prncnt)
    Next
    PrintForm.ComboBox1.Value = Application.ActivePrinter ' âûáîð ïðèíòåðà
    PrintForm.Show
    Application.ScreenUpdating = True
End Sub

Public Function PrinterFind(Optional Match As String) As String()
    Dim n%, lRet&, sBuf$, sCon$, aPrn$()
    Dim prnstr As Boolean
    Const lLen& = 1024, sKey$ = "devices"
    aPrn = Split(Excel.ActivePrinter)
    If InStr(aPrn(UBound(aPrn)), "(") Then prnstr = True
    sCon = " " & aPrn(UBound(aPrn) - 1) & " " '
    sBuf = Space(lLen)
    lRet = GetProfileString(sKey, vbNullString, vbNullString, sBuf, lLen)
    If lRet = 0 Then
        Err.Raise vbObjectError + 513, , "Can't read Profile"
        Exit Function
    End If
    aPrn = Split(Left(sBuf, lRet - 1), vbNullChar)
    If Match <> vbNullString Then aPrn = Filter(aPrn, Match, -1, 1)
    For n = LBound(aPrn) To UBound(aPrn)
        sBuf = Space(lLen)
        lRet = GetProfileString(sKey, aPrn(n), vbNullString, sBuf, lLen)
        If prnstr Then
            aPrn(n) = aPrn(n) & " (" & Mid(sBuf, InStr(sBuf, ",") + 1, lRet - InStr(sBuf, ",") - 1) & ":)"
        Else
            aPrn(n) = aPrn(n) & " on " & Mid(sBuf, InStr(sBuf, ",") + 1, lRet - InStr(sBuf, ",") - 1) & ":"
        End If
    Next
    PrinterFind = aPrn
End Function

.Attachments.Add Range("A4").Value