Sub ImportSheet()
       Dim sImportFile As String, sFile As String
       Dim sThisBk As Workbook
       Dim impSh As Worksheet
       Dim vfilename As Variant
       Dim oNewRow As ListRow
       Dim svod As ListObjects
          
       Application.ScreenUpdating = False
       Application.DisplayAlerts = False
          
       Set sThisBk = ActiveWorkbook
       sImportFile = Application.GetOpenFilename( _
       FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", Title:="Импорт проекта")
       If sImportFile = "False" Then
           MsgBox "Ничего не выбрано!"
           Exit Sub
               
       Else        'Из выбранного файла выделяем путь к файлу
           vfilename = Split(sImportFile, "\")
           sFile = vfilename(UBound(vfilename))
           Application.Workbooks.Open Filename:=sImportFile
                   'Открываем файл по ссылке и ищем лист с указанным названием
           Set wbBk = Workbooks(sFile)
            
           For Each impSh In wbBk.Sheets
           If impSh.Name Like "Проект" Then
                   impSh.Copy after:=obzor
                   ActiveSheet.Name = "Проект№" & (ThisWorkbook.Sheets.Count - 1)
              Else: End If
           Next impSh
           wbBk.Close SaveChanges:=False
       End If
       Application.ScreenUpdating = True
       Application.DisplayAlerts = True
End Sub