Sub ВставкаБракСтыки()
   
    Dim shSrc As Worksheet, arrSrc()
    Dim shRes As Worksheet, arrRes(), r As Long
    Dim strFN_src As String
    Dim lr As Long, i As Long
   
   
    '1. Юзер выбирает файл-источник.
    'strFN_src = GetFilePath
    'If strFN_src = "" Then Exit Sub
   
    '2. Отключение монитора, чтобы ускорить работу макроса и чтобы меньше мигало.
    Application.ScreenUpdating = False
   
    '3. Присваивание листу-результату имени "shRes". Затем через это имя удобно обращаться к листу в коде.
    Set shRes = ActiveSheet
   
    '4. Открытие файла-источника.
        ' Листу "М 2-40" присваивается имя "shSrc".
        ' ReadOnly:=True - нам нужно открыть только для чтения. Это может чем-нибудь упростить макрос.
    Set shSrc = Workbooks.Open(Filename:="\\10.38.9.251\велесстрой2\Велесстрой Монтаж\04 ОПП\3.Коренюгин К.С\стыки\10)Трассовка М 2-40 (СМУ-ВМ-ТМ)..xlsb", ReadOnly:=True).Worksheets("М 2-40")
   
    '5. Копирование некоторых данных из листа-источника в массив. С массивом быстрее работать, чем с эксель-ячейками.
        ' На листе не должно быть скрытых строк, иначе некоторые строки могут быть не учтены.
    lr = shSrc.Cells(shSrc.Rows.Count, "A").End(xlUp).Row
    arrSrc() = shSrc.Range("A1:BP" & lr).Value
   
    '6. Создание ячеек в массиве-результате. Сначала в него запишутся данные, а затем он
        ' будет вставлен на эксель-лист. Это ускорит работу макроса.
        ' Строк создаётся максимально возможное кол-во, т.к. заранее не известно, сколько будет строк с данными.
    ReDim arrRes(1 To UBound(arrSrc, 1), 1 To 68)
   
    '7. Копирование данных из листа-источника в массив-результат.
    For i = 2 To UBound(arrSrc, 1)
        If (arrSrc(i, 33).Interior.Color = 255) And (arrSrc(i, 68) = "ВМ") Then
             r = r + 1
            arrRes(r, 1) = arrSrc(i, 1)
            arrRes(r, 2) = arrSrc(i, 2)
            arrRes(r, 3) = arrSrc(i, 3)
            arrRes(r, 4) = arrSrc(i, 4)
            arrRes(r, 5) = arrSrc(i, 5)
            arrRes(r, 6) = arrSrc(i, 6)
            arrRes(r, 7) = arrSrc(i, 7)
                      
            arrRes(r, 7) = shSrc.Cells(i, 7).Value
        End If
    Next i
   
    '8. Закрытие файла-источника.
    shSrc.Parent.Close SaveChanges:=False
   
    '9. Действия, если не было найдено нужных строк.
    If r = 0 Then
        Application.ScreenUpdating = True
        MsgBox "В файле-источнике нет нужных данных.", vbExclamation
        Exit Sub
    End If
   
    '10. Вставка данных на лист-результат.
    shRes.Range("B2").Resize(r, UBound(arrRes, 2)).Value = arrRes()
   
    '11. Включение монитора.
    Application.ScreenUpdating = True
   
End Sub