Sub Перенос_данных_в_БРЗ()
'Заключаем данную книгу в переменную
Dim tWB As Workbook
Set tWB = ThisWorkbook

'Указываем путь в файлу БРЗ
Dim nWB As Variant
Set nWB = Workbooks.Open(Filename:="D:\VB\Перенос значений\БРЗ.xlsx")

'Организовываем цикл по листам со сверкой их названий (лист присутствует в обеих книгах)
Dim shA As Worksheet
Dim shB As Worksheet
Dim arr

For Each shA In tWB.Sheets 'лист в Сверке
   For Each shB In nWB.Sheets 'лист в БРЗ
    If shA.Name = shB.Name Then
        If Not IsArray(arr) Then
            ReDim arr(1 To 1): arr(1) = shA.Name
                shA.Range("B4").Copy
                shB.Activate
                shB.Range("C4").PasteSpecial xlPasteValues
                
                shA.Activate
                
                shA.Range("C4").Copy
                shB.Activate
                shB.Range("C5").PasteSpecial xlPasteValues
                
                shA.Activate
                
                shA.Range("D4").Copy
                shB.Activate
                shB.Range("C6").PasteSpecial xlPasteValues: Exit For
    Else
        ReDim Preserve arr(1 To UBound(arr) + 1)
            arr(UBound(arr)) = shA.Name
                MsgBox ("Такого листа нет в БРЗ")
        End If
    End If
  Next
Next

End Sub

Sub Перенос_данных_в_БРЗ()
'Заключаем данную книгу в переменную
Dim tWB As Workbook
Set tWB = ThisWorkbook

'Указываем путь в файлу БРЗ
Dim nWB As Variant
Set nWB = Workbooks.Open(Filename:="D:\VB\Перенос значений\БРЗ.xlsx")

'Организовываем цикл по листам со сверкой их названий (лист присутствует в обеих книгах)
Dim shA As Worksheet
Dim shB As Worksheet
Dim arr

For Each shA In tWB.Sheets 'лист в Сверке
   For Each shB In nWB.Sheets 'лист в БРЗ
    If shA.Name = shB.Name Then
        'If Not IsArray(arr) Then
            'ReDim arr(1 To 1): arr(1) = shA.Name
                shA.Range("B4").Copy
                shB.Activate
                shB.Range("C4").PasteSpecial xlPasteValues
                
                shA.Activate
                
                shA.Range("C4").Copy
                shB.Activate
                shB.Range("C5").PasteSpecial xlPasteValues
                
                shA.Activate
                
                shA.Range("D4").Copy
                shB.Activate
                shB.Range("C6").PasteSpecial xlPasteValues ': Exit For
    Else
        'ReDim Preserve arr(1 To UBound(arr) + 1)
            'arr(UBound(arr)) = shA.Name
                MsgBox ("Такого листа нет в БРЗ") 'ПОЯВЛЯЕТСЯ КАЖДЫЙ РАЗ ПРИ СОПОСТОВЛЕНИИ РАЗНЫХ ЛИСТОВ. НАДО ЧТОБЫ ПОЯВЛЯЛСЯ, КОГДА ЛИСТА НЕТ В КНИГЕ
        End If
    'End If
  Next
Next

End Sub

Sub Перенос_данных_в_БРЗ()
'Заключаем данную книгу в переменную
Dim tWB As Workbook
Set tWB = ThisWorkbook

Dim nWB As Variant
'Указываем путь в файлу БРЗ
Set nWB = Workbooks.Open(Filename:="D:\VB\Перенос значений\БРЗ.xlsx")

'Организовываем цикл по листам со сверкой их названий (лист присутствует в обеих книгах)
Dim shA As Worksheet
Dim shB As Worksheet
Dim arr() As String

For Each shA In tWB
  For Each shB In nWB
    If shA.Name = shB.Name Then
      If Not IsArray(arr) Then
        ReDim arr(1 To 1): arr(1) = shA.Name: Exit For
      Else
        ReDim Preserve arr(1 To UBound(arr) + 1)
        arr(UBound(arr)) = shA.Name: Exit For
      End If
    End If
  Next
Next

End Sub

Sub Перенос_данных_в_БРЗ()
'Заключаем данную книгу в переменную
Dim tWB As Workbook
Set tWB = ThisWorkbook

Dim nWB As Range
'Указываем путь в файлу БРЗ
Set nWB = Worksheets("ПЕРЕНОС в БРЗ").Range("C2")

'Открываем файл с БРЗ
Workbooks.Open Filename:=nWB

'Организовываем цикл по листам со сверкой их названий (лист присутствует в обеих книгах)
Dim shA As Worksheet
Dim shB As Worksheet
Dim arr() As String

For Each shA In tWB
  For Each shB In nWB
    If shA.Name = shB.Name Then
      If Not IsArray(arr) Then
        ReDim arr(1 To 1): arr(1) = shA.Name: Exit For
      Else
        ReDim Preserve arr(1 To UBound(arr) + 1)
        arr(UBound(arr)) = shA.Name: Exit For
      End If
    End If
  Next
Next

End Sub

Option Explicit

Sub Перенос_данных_в_БРЗ()

Dim oRange As Range
'Указывает путь в файлу БРЗ
Set oRange = Worksheets("ПЕРЕНОС в БРЗ").Range("C2")

'Открываем файл с БРЗ
Workbooks.Open Filename:=oRange

Dim sh As Worksheet

Dim lists As Range
Set lists = Workbooks("Сверка.xlsb").Worksheets("ПЕРЕНОС в БРЗ").Range("C5")

For Each sh In Worksheets
If sh.Name = lists Then Exit For
MsgBox ("Good!")

Next
If sh Is Nothing Then MsgBox "Лист " & lists & " не найден": Exit Sub
End Sub

=ЕСЛИ(ЕЧИСЛО(ПОИСКПОЗ(A1;Массив1!$A$1:$A$2;0));"Есть";ЕСЛИ(ЕЧИСЛО(ПОИСКПОЗ(A1;Массив2!$A$1:$A$2;0));"Есть";"Значения нет")) 

=ЕСЛИ(ЕЧИСЛО(ПОИСКПОЗ(ЛЕВСИМВ(A1;3);(ЛЕВСИМВ(Массив1!$A$1:$A$10;3));0));"Есть";ЕСЛИ(ЕЧИСЛО(ПОИСКПОЗ(ЛЕВСИМВ(A1;3);(ЛЕВСИМВ(Массив1!$A$1:$A$10;3));0));"Есть";"Значения нет"))

Private Sub Send()
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
    Dim lr As Long, lLastR As Long
 
    Application.ScreenUpdating = False
    On Error Resume Next
   
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
    objOutlookApp.Session.Logon
 
    lLastR = Cells(Rows.Count, 1).End(xlUp).Row
    
    For lr = 2 To lLastR
        Set objMail = objOutlookApp.CreateItem(0)
       
        With objMail
            .to = Cells(1, 8).Value
            .Cc = Cells(2, 8).Value
            .Cc = Cells(3, 8).Value
            .Subject = Cells(4, 8).Value
            .Body = Cells(5, 8).Value
            .Attachments.Add Cells(lr, 2).Value
            .Send
        End With
    Next lr
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
    
End Sub