Страницы: Пред. 1 2 3 4 5 6 7 След.
RSS
Подборка функций пользователя
 
Всем доброго дня!

Смотрю тут, на форуме, в последнее время активно обсуждаются регулярные выражения. Написал на досуге пользовательскую функцию "Поиск и извлечение уникальных значений с помощью регулярных выражений".
Что ищем и извлекаем:
1 - адреса электронной почты;
2 - номера сотовых телефонов;
3 - номера автомобилей;
4 - IP-адреса;
5 - URL.
Первый аргумент функции - диапазон ячеек с текстом, второй - порядковый номер из списка. Регулярные выражения зашиты в код функции. Можно их добавлять и расширять функционал.
Если у кого есть предложения по расширению списка извлекаемых конструкций - пишите.
Код
Function ExtractUniqueRegExp(DataRange As Range, Optional k As Byte = 1)
    Dim arrRegExp() As Variant, Cell As Range, Text As String, _
        Coll As New Collection, i As Long, j As Long, tmp As String
    arrRegExp = Array("", _
        "\b[A-Z0-9._%+-]+@(?:[A-Z0-9-]+\.)+[A-Z]{2,6}\b", _
        "(\+7|8)[- ]?\(?\d{3}\)?([- ]?\d){7}\b", _
        "\s[АВЕКМНОРСТУХ]\d{3}[АВЕКМНОРСТУХ]{2}\d{2,3}\b", _
        "\b((25[0-5]|2[0-4]\d|1\d{2}|\d{1,2})\.){3}(25[0-5]|2[0-4]\d|1\d{2}|\d{1,2})(\s|$)", _
        "https?:\/\/(\w*:\w*@)?[-\w.]+(:\d+)?(\/([-\w\/_.]*(\?\S+)?)?)?")
    For Each Cell In DataRange
        Text = Text & " " & Cell
    Next Cell
    With CreateObject("VBScript.RegExp")
        .Pattern = arrRegExp(k)
        .Global = True
        .IgnoreCase = True
        If .Test(Text) Then
            On Error Resume Next
            ReDim uniArr(0 To Application.Caller.Rows.Count - 1, 0 To 0) As String
            For i = 0 To .Execute(Text).Count - 1
                tmp = .Execute(Text)(i)
                If k = 2 Then tmp = Replace(Replace(Replace(Replace(Replace _
                    (tmp, "+7", "8"), "(", ""), ")", ""), "-", ""), " ", "")
                If k = 3 Then tmp = Replace(tmp, Left(tmp, 1), "")
                Coll.Add tmp, CStr(tmp)
                If Not IsEmpty(tmp) And Err = 0 Then uniArr(j, 0) = tmp: j = j + 1 Else Err.Clear
            Next i
            ExtractUniqueRegExp = uniArr
        Else
            ExtractUniqueRegExp = ""
        End If
    End With
End Function
 
Привет!
Через месяц Вы вспомните какой элемент массива какой паттерн?
Пора отказываться от спагетти-кода!
Сравнение прайсов, таблиц - без настроек
 
Inexsu, можно закомментировать в коде какой паттерн чему соответствует, тем более не так уж и много стандартных конструкций для извлечения.
Предложите свои варианты кода.
Изменено: Evgenyy - 02.08.2019 15:24:57
 
Строка
Код
Coll.Add tmp, CStr(tmp)
очень нужна?
Сравнение прайсов, таблиц - без настроек
 
Да, эта строка нужна. С помощью её и последующей наполняем массив уникальными, не повторяющимися, значениями. Допустим у нас в тексте один и тот же адрес электронной почты встречается 10 раз. Нам же не надо его выводить 10 раз, один раз извлекли и достаточно.
 
Цитата
Evgenyy написал:
Да, эта строка нужна
Код как юмор.
Если его нужно объяснять - он плохой.
Сравнение прайсов, таблиц - без настроек
 
Evgenyy,  Можно вот так записать
Код
        Const A = "\b[A-Z0-9._%+-]+@(?:[A-Z0-9-]+\.)+[A-Z]{2,6}\b"
        Const B = "(\+7|8)[- ]?\(?\d{3}\)?([- ]?\d){7}\b"
        Const C = "\s[АВЕКМНОРСТУХ]\d{3}[АВЕКМНОРСТУХ]{2}\d{2,3}\b"
        Const D = "\b((25[0-5]|2[0-4]\d|1\d{2}|\d{1,2})\.){3}(25[0-5]|2[0-4]\d|1\d{2}|\d{1,2})(\s|$)"
        Const E = "https?:\/\/(\w*:\w*@)?[-\w.]+(:\d+)?(\/([-\w\/_.]*(\?\S+)?)?)?"
    arrRegExp = Array("", A, B, C, D, E)

дав константам понятные имена
По вопросам из тем форума, личку не читаю.
 
У Evgenyy, код заточен под лист, поэтому паттерны регулярных нагляднее держать на листе.
Сравнение прайсов, таблиц - без настроек
 
Цитата
Inexsu написал:
нагляднее держать на листе.
для примера или полуфабриката - наверно соглашусь, но для готовой функции - нет, она должна быть самодостаточна. а вот описание аргументов в шапку функции я б в комментариях указывал. ну как пример у Игоря
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал:
готовой функции - нет, она должна быть самодостаточна
Пусть код сложный, пусть спагетти. Но он работает :-)
А Вы призываете код регулярно изменять. Он и так хрупкий.
Берите паттерн регулярки не номером, а самим паттерном и не нужно будет ковыряться в коде.
Ну вы же знаете, что после исправления кода, нужно запускать тесты?  
Сравнение прайсов, таблиц - без настроек
 
Inexsu,  Нет, я не призываю код менять постоянно. В данном случае есть готовая функция с пятью готовыми шаблонами , действующий выбирается одним из аргументов, и для рядового пользователя, который просто перенес её в свой файл - этого может быть достаточно, не полезет он редактировать то, чего совсем не понимает.
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал:
как  пример у Игоря
Как внештатный ученик Игоря, надеюсь он Вас и отругает за странное стремление ограничить универсальность процедуры :-)
Сравнение прайсов, таблиц - без настроек
 
Цитата
Inexsu написал:
Пора отказываться от спагетти-кода!
Решил избавиться от массива. Так лучше?
Код
Function ExtractUniqueRegExp(DataRange As Range, Optional k As Byte = 1)
'       k: 1 - email; 2 - tel; 3 - car number; 4 - IP-address; 5 - URL
    Dim Pattern As String, Cell As Range, Text As String, _
        Coll As New Collection, i As Long, j As Long, tmp As String
    For Each Cell In DataRange
        Text = Text & " " & Cell
    Next Cell
    Select Case k
        Case 1: Pattern = "\b[A-Z0-9._%+-]+@(?:[A-Z0-9-]+\.)+[A-Z]{2,6}\b"
        Case 2: Pattern = "(\+7|8)[- ]?\(?\d{3}\)?([- ]?\d){7}\b"
        Case 3: Pattern = "\s[АВЕКМНОРСТУХ]\d{3}[АВЕКМНОРСТУХ]{2}\d{2,3}\b"
        Case 4: Pattern = "\b((25[0-5]|2[0-4]\d|1\d{2}|\d{1,2})\.){3}(25[0-5]|2[0-4]\d|1\d{2}|\d{1,2})(\s|$)"
        Case 5: Pattern = "https?:\/\/(\w*:\w*@)?[-\w.]+(:\d+)?(\/([-\w\/_.]*(\?\S+)?)?)?"
    End Select
    With CreateObject("VBScript.RegExp")
        .Pattern = Pattern
        .Global = True
        .IgnoreCase = True
        If .Test(Text) Then
            On Error Resume Next
            ReDim uniArr(0 To Application.Caller.Rows.Count - 1, 0 To 0) As String
            For i = 0 To .Execute(Text).Count - 1
                tmp = .Execute(Text)(i)
                If k = 2 Then tmp = Replace(Replace(Replace(Replace(Replace _
                    (tmp, "+7", "8"), "(", ""), ")", ""), "-", ""), " ", "")
                If k = 3 Then tmp = Replace(tmp, Left(tmp, 1), "")
                Coll.Add tmp, CStr(tmp)
                If Not IsEmpty(tmp) And Err = 0 Then uniArr(j, 0) = tmp: j = j + 1 Else Err.Clear
            Next i
            ExtractUniqueRegExp = uniArr
        Else
            ExtractUniqueRegExp = ""
        End If
    End With
End Function
 
Inexsu, Не существует универсальной процедуры.  Есть или узко специализированные , или гибкие. Если Evgenyy представил функцию которая из диапазона ( к стати только из диапазона, а значит уже не так универсально) извлекает уникальные значения по типам указанным во втором аргументе, то это специализированная функция. Если, даже забыть про первый аргумент, и в качестве второго давать шаблон, то это будет уже другая функция, возвращающая уникальные значения из диапазона, подходящие под пользовательский шаблон.
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал:
к стати только из диапазона, а значит уже не так универсально
А из чего ещё извлекать, чтоб было универсально?
 
Цитата
Evgenyy написал:
из чего ещё извлекать, чтоб было универсально?
Не могу пока обосновать, считаю, что
Код
CreateObject("VBScript.RegExp").Execute 
принимает на вход тип String.
Сравнение прайсов, таблиц - без настроек
 
Evgenyy, Массив.  изменений не много
DataRange As Variant
и на случай единичного элемента
Код
    If IsArray(DataRange) Then
        For Each ItemVal In DataRange
            Text = Text & " " & ItemVal
        Next ItemVal
    Else
        Text = DataRange
    End If

Тогда и диапазон и массив и одиночное значение обработает.
По вопросам из тем форума, личку не читаю.
 
Цитата
Evgenyy написал:
Так лучше?
Для достижения повторного использования кода, тестирования, надекомпозировал:
Код
Function Массив_Уникальных_из_Диапазона( _
         r As Range, _
         sPatt As String) _
         As Variant

    Dim s As String
    s = Диапазон_в_Строку(r)

    Массив_Уникальных_из_Диапазона = _
    Объект_в_Словарь( _
    Регулярка_Взять(s, sPatt, _
                    Регулярка_Тест(s, sPatt))). _
                    Keys

End Function
Изменено: Inexsu - 03.08.2019 11:30:09
Сравнение прайсов, таблиц - без настроек
 
БМВ, как-то так:
Код
Function ExtractUniqueRegExp(DataRange As Variant, Optional k As Byte = 1)
'       k: 1 - email; 2 - tel; 3 - car number; 4 - IP-address; 5 - URL
    Dim Pattern As String, Cell As Range, ItemVal As Variant, Text As String, _
        Coll As New Collection, i As Long, j As Long, tmp As String
    If IsArray(DataRange) Then
        For Each ItemVal In DataRange
            Text = Text & " " & ItemVal
        Next ItemVal
    Else
        For Each Cell In DataRange
            Text = Text & " " & Cell
        Next Cell
    End If
    Select Case k
        Case 1: Pattern = "\b[A-Z0-9._%+-]+@(?:[A-Z0-9-]+\.)+[A-Z]{2,6}\b"
        Case 2: Pattern = "(\+7|8)[- ]?\(?\d{3}\)?([- ]?\d){7}\b"
        Case 3: Pattern = "\s[АВЕКМНОРСТУХ]\d{3}[АВЕКМНОРСТУХ]{2}\d{2,3}\b"
        Case 4: Pattern = "\b((25[0-5]|2[0-4]\d|1\d{2}|\d{1,2})\.){3}(25[0-5]|2[0-4]\d|1\d{2}|\d{1,2})(\s|$)"
        Case 5: Pattern = "https?:\/\/(\w*:\w*@)?[-\w.]+(:\d+)?(\/([-\w\/_.]*(\?\S+)?)?)?"
    End Select
    With CreateObject("VBScript.RegExp")
        .Pattern = Pattern
        .Global = True
        .IgnoreCase = True
        If .Test(Text) Then
            On Error Resume Next
            ReDim uniArr(0 To Application.Caller.Rows.Count - 1, 0 To 0) As String
            For i = 0 To .Execute(Text).Count - 1
                tmp = .Execute(Text)(i)
                If k = 2 Then tmp = Replace(Replace(Replace(Replace(Replace _
                    (tmp, "+7", "8"), "(", ""), ")", ""), "-", ""), " ", "")
                If k = 3 Then tmp = Replace(tmp, Left(tmp, 1), "")
                Coll.Add tmp, CStr(tmp)
                If Not IsEmpty(tmp) And Err = 0 Then uniArr(j, 0) = tmp: j = j + 1 Else Err.Clear
            Next i
            ExtractUniqueRegExp = uniArr
        Else
            ExtractUniqueRegExp = ""
        End If
    End With
End Function
 
Цитата
Inexsu написал:
надекомпозировал:
Коллега, вы всерьёз считаете, что Excel-формульное представление - это удобное естественное представление кода?
 
Evgenyy,  Еще пара вопросов. В чем смысл двумерности uniArr?
Почему не возвращать массив, без привязки к Application.Caller.Rows.Count?  Например я хочу  ( как формулист) передать массив {"192.168.1.1";"192.168.1.1";"192.168.1.2"} , это мы сделали, получить в ответ {"192.168.1.1 ";"192.168.1.2"} . При использовании формулы массива для диапазона автоматически разобъется на ячейки, а при использовании вложенности в другую функцию - будет массив для обработки.

И это не критика, а скорее толчки к развитию.
Изменено: БМВ - 03.08.2019 13:03:05
По вопросам из тем форума, личку не читаю.
 
и меня просто поражает с какой настойчивостью на форуме люди выбирают уникальные значения, которые не являются уникальными по определению этого слова, взятому в любом толковом словаре русского языка
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, у Вас филологическое образование?
Одно из определений слова "уникальный" - неповторимый, единственный в своём роде.
В этом контексте это слово здесь и употребляется!
 
Добрый день, коллеги! Присоединяюсь в благодарностям автору за большую, с любовью проделанную работу.
Пара вопросов общего характера.
  • Этот сборник макросов предназначен только для тех пользователей Excel, у которых кодовая таблица по умолчанию windows-1251? Многие функции не будут работать на иных кодовых таблицах.
  • Не нашел описаний макросов: назначение, описание параметров и возвращаемого значения (функции), ссылка на источник (откуда взят макрос), особенности использования.
Владимир
 
БМВ, уберите двумерность, посмотрите что получиться.
По поводу привязки к Application.Caller.Rows могу сказать, что изначально не рассматривал извлечение из массива, а только из диапазона в диапазон.
Изменено: Evgenyy - 03.08.2019 13:51:46
 
Цитата
Evgenyy написал:
БМВ , уберите двумерность, посмотрите что получиться.
да тоже самое , если при двумерности расположить формулы не в столбец, а в строку.
Application.Caller.Rows  - к массиву входных параметров не относится.  Это то, где формула расположена и относится к диапазону где введена формула массива.
По вопросам из тем форума, личку не читаю.
 
sokol92, этот сборник макросов (UDF5.xlsb) я составлял для себя, у меня установлена Windows 7 + Excel 2007. Всё прекрасно работает. В вопросах применения кодовых таблиц я не компетентен. Все материалы взяты из различных открытых источников. Небольшая часть функций написана мною, другие переработаны и отредактированы под мой "вкус". Используйте и применяйте как есть. Если есть какие-либо пожелания или советы, с благодарностью их приму.
Изменено: Evgenyy - 03.08.2019 14:14:40
 
Цитата
Андрей VG написал:
вы всерьёз считаете, что Excel-формульное представление
Всерьёз.
Для себя называю чуть по другому: цепочка методов, а под настроение и:
Иерархия
 Декорированных
   Артефактов
Сравнение прайсов, таблиц - без настроек
 
Цитата
БМВ написал:
толчки к развитию
Золотые слова!
Коды Ваших процедур работают, но они заточены под функции листа.
Я уже несколько раз переделывал системы Excel, которые заточены под формулы, на вставку значений.
Да, скорость.
Сравнение прайсов, таблиц - без настроек
 
Inexsu, Для набора функций - это действительно эффективно( библиотеки, надсстройки) , а вот для единичных, да еще коротких - сомневаюсь. При таком подходе необходимо еще в каждой процедуре описывать тот набор функций, что используется, чтоб в случае переноса, не пропустить чего.
По вопросам из тем форума, личку не читаю.
Страницы: Пред. 1 2 3 4 5 6 7 След.
Наверх