Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) = "I8" Then
        Dim s As String
        Dim dic As Object
        Set dic = GetDic(Target.Value)
        
        GetSh dic
        
        Dim rangeName As Variant
        For Each rangeName In Array("B28", "B37")
            SetS rangeName
        Next
    End If
End Sub
 Sub SetS(ByVal rangeName As String)
    With Range(rangeName).Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Список"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
End Sub
Function GetDic(ByVal TargetValue As String) As Object
    Const fileFullName = "C:\tmp\Реестр Регистрации инициатив текущий.xlsx"
    Const wbName = "Реестр Регистрации инициатив текущий.xlsx"
    Const shName = "Карьер"
    
    Dim s As String
    Dim v As Variant
    
    Dim sh As Worksheet
    Dim wb As Workbook
    
    On Error Resume Next
        Set wb = Workbooks(wbName)
    On Error GoTo 0
    If wb Is Nothing Then
        Set wb = Workbooks.Open(fileFullName, False, True)
    End If
    ThisWorkbook.Activate
    
    On Error Resume Next
        Set wb = Workbooks(wbName)
        If Err <> 0 Then
            s = "Не вижу файл " & Chr(10) & wbName & Chr(10) & Chr(10) & "Вижу файлы:" & Chr(10)
            For Each v In Application.Workbooks
                s = s & v.Name & Chr(10)
            Next
            MsgBox s, vbInformation
            Exit Function
        End If
        
        Set sh = wb.Sheets(shName)
        If Err <> 0 Then
            s = "Не вижу лист " & Chr(10) & shName & Chr(10) & Chr(10) & "Вижу листы:" & Chr(10)
            For Each v In wb.Worksheets
                s = s & v.Name & Chr(10)
            Next
            MsgBox s, vbInformation
            
            
            Exit Function
        End If
    On Error GoTo 0
    
    Dim r1 As Range: Set r1 = sh.Columns("F:F")
    Dim r2 As Range: Set r2 = sh.Columns("J:J")
    Dim y As Long
    Dim a1 As Variant
    Dim a2 As Variant
    With sh
        y = .Cells(.Rows.Count, r1.Column).End(xlUp).Row
        a1 = .Range(.Cells(1, r1.Column), .Cells(y, r1.Column))
        a2 = .Range(.Cells(1, r2.Column), .Cells(y, r2.Column))
    End With
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For y = 1 To UBound(a1, 1)
        If a1(y, 1) = TargetValue Then
            dic(a2(y, 1)) = 0
        End If
    Next
    Set GetDic = dic
    
    Application.StatusBar = Left(TargetValue & " ", 255)
End Function
Sub GetSh(dic As Object)
    Dim shList As Worksheet
    On Error Resume Next
        Set shList = ThisWorkbook.Worksheets("Список")
    On Error GoTo 0
    If shList Is Nothing Then
        Set shList = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        shList.Name = "Список"
    End If
    With shList
        .Visible = xlSheetHidden
        .Cells.Clear
        With .Cells(1, 1).Resize(, dic.Count)
            .Cells = dic.keys()
            Dim sR1C1 As String
            sR1C1 = .Address(1, 1, xlR1C1)
        End With
        sR1C1 = "=" & .Name & "!" & sR1C1
    End With
    
    Dim n As Name
    On Error Resume Next
        Set n = ThisWorkbook.Names("Список")
        n.RefersToR1C1 = sR1C1
    On Error GoTo 0
    If n Is Nothing Then ThisWorkbook.Names.Add Name:="Список", RefersToR1C1:=sR1C1
End Sub