Имя пользователя:
Пароль:  
Помощь | Регистрация | Забыли пароль?  

Показать сообщение отдельно

Динохромный


Contributor


Сообщения: 712
Благодарности: 322

Профиль | Отправить PM | Цитировать


Цитата Swit0:
А если мне нужно указать несколько организаций через запятую, без поиска »
Swit0, я обычно выступаю за визуальный контроль того, что делает программа. Предлагаю такой вариант: перечень организаций вы вводите через запятую+пробел, запускаете код ниже. Код присваивает найденным диапазонам имена, которые вы можете выбрать либо в окне имя (которое находится левее окна формул, чуть выше ячейки А1 - рядом с адресом выделенной ячейки есть стрелочка, нажав на которую вы получите список именованных диапазонов), либо через горячую клавишу F5. Диапазон по этому действию выделяется, дальше вы его аналогично удаляете (либо оставляете). Если код не найдет какой-то запрос, после выполнения он выбросит окно.
Код: Выделить весь код
Public Sub naming_for_deleting()
    Dim rngStart As Range, rngEnd As Range, i As Integer
    Dim strStart As String, strEnd As String, strF As String, strErr As String, vrtTxt As Variant
    strF = InputBox("Введите через запятую (с пробелом) перечень", "Поиск", "ООО ЗСТ, ООО ВВВВ, ООО ООО, ООО МММ")
    vrtTxt = Split(strF, ", ")
    On Error Resume Next
    For i = LBound(vrtTxt) To UBound(vrtTxt)
        strStart = vrtTxt(i)
        strEnd = "Всего по: " & vrtTxt(i)
        Set rngStart = Cells.Find(What:=strStart, After:=ActiveSheet.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        Set rngEnd = ActiveSheet.Cells.Find(What:=strEnd, After:=rngStart, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        If Err.Number <> 0 Then
            strErr = strErr & strStart & ","
            Err.Clear
        Else
            ActiveWorkbook.Names.Add Name:=Replace(strStart, " ", "_"), RefersTo:="=" & ActiveSheet.Name & "!" & Range(rngStart, rngEnd).EntireRow.Address
        End If
        
        Set rngStart = Nothing
        Set rngEnd = Nothing
    Next i
    
    If strErr <> "" Then MsgBox "Не найдены следующие запросы:" & strErr
    
    
End Sub
Удаляете вы все также сочетанием ctrl+знак минуса, но беда в том, что при удалении диапазона его имя все равно останется в рабочей книге со значением ошибки. Это не смертельно, но лучше эти имена удалять, например с помощью кода ниже (удалит все доступные имена с ошибкой, не затрагивая правильные имена).
Код: Выделить весь код
Public Sub del_names_err()
    Dim namObj As Name
    For Each namObj In ActiveWorkbook.Names
        If namObj.RefersTo Like "*[#]REF[!]*" Then namObj.Delete
    Next
End Sub
Это сообщение посчитали полезным следующие участники:

Отправлено: 13:43, 20-02-2018 | #7