Sub Путь_к_файлу()
    Dim FilesToOpen
    Dim OpenPath As String
    OpenPath = CStr(ThisWorkbook.Path)
    'ChDrive "C:\Program Files"
    ChDrive OpenPath
    ChDir OpenPath
    FilesToOpen = Application.GetOpenFilename _
        ("Excel files(*.xls*),*.xls*", 1, "Выбрать файл", , False)
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Файл не выбран!"
        Exit Sub
    End If
    Cells(2, "D") = FilesToOpen
End Sub
Sub Получить()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Dim Dict As Object
    Dim Links As Variant
    Set Dict = CreateObject("scripting.dictionary"): Dict.comparemode = 1
   
    With Sheets("Лимиты")
        lr = .Cells(.Rows.Count, "K").End(xlUp).Row
        If lr > 1 Then
            For i = 2 To lr
                If Not Dict.exists(.Cells(i, "K").Value) And .Cells(i, "K").Value <> "" Then Dict.Add (.Cells(i, "K").Value), 1
            Next
        End If
    End With
    n = 0
    For Each vkey In Dict.Keys
        n = n + 1
        Application.StatusBar = CStr(n) + " " + vkey
        'Создаем файлы
        Set new_wb = Workbooks.Add
        
        ThisWorkbook.Sheets("Лимиты").Copy Before:=Sheets(1)
        Sheets(1).Visible = True
        
        lr = Cells(Rows.Count, "K").End(xlUp).Row
        For i = lr To 2 Step -1
            If Cells(i, "K") <> vkey Then Rows(i).Delete
        Next
        Sheets(1).Columns("K").Delete
        ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
        
        new_wb.SaveAs ThisWorkbook.Path + "\" + vkey + ".xlsx"
        new_wb.Close
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Отчёты успешно созданы!", vbInformation, "Информация"
End Sub