MyTetra Share
Делитесь знаниями!
Удаление проверки данных
Время создания: 26.05.2020 16:28
Текстовые метки: проверка данных, Validation, Names
Раздел: !Закладки - VBA - Excel - Names



Option Explicit

'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          https://www.excel-vba.ru
'          info@excel-vba.ru
'          WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
' Purpose:
'---------------------------------------------------------------------------------------
Sub FindErrLink()
    'надо посмотреть в Данные -Изменить связи ссылку на файл-иточник
    'и записать сюда ключевые слова в нижнем регистре(часть имени файла)
    'звездочка просто заменяет любое кол-во символов, чтобы не париться с точным названием
    Const sToFndLink$ = "*продажи 2018*"
 
    Dim rr As Range, rc As Range, rres As Range, s$
    'определяем все ячейки с проверкой данных
    On Error Resume Next
    Set rr = ActiveSheet.UsedRange.SpecialCells(xlCellTypeAllValidation)
    If rr Is Nothing Then
        MsgBox "На активном листе нет ячеек с проверкой данных", vbInformation, "www.excel-vba.ru"
        Exit Sub
    End If
    On Error GoTo 0
    'проверяем каждую ячейку на предмет наличия связей
    For Each rc In rr
        'на всякий случай пропускаем ошибки - такое тоже может быть
        'но наши связи должны быть без них и они точно отыщутся
        s = ""
        On Error Resume Next
        s = rc.Validation.Formula1
        On Error GoTo 0
        'нашли - собираем все в отдельный диапазон
        If LCase(s) Like sToFndLink Then
            If rres Is Nothing Then
                Set rres = rc
            Else
                Set rres = Union(rc, rres)
            End If
        End If
    Next
    'если связь есть - выделяем все ячейки с такими проверками данных
    If Not rres Is Nothing Then
        rres.Select
'        rres.Interior.Color = vbRed 'если надо выделить еще и цветом
    End If
End Sub
 
MyTetra Share v.0.53
Яндекс индекс цитирования