Всем доброго дня!
Смотрю тут, на форуме, в последнее время активно обсуждаются регулярные выражения. Написал на досуге пользовательскую функцию "Поиск и извлечение уникальных значений с помощью регулярных выражений".
Что ищем и извлекаем:
1 - адреса электронной почты;
2 - номера сотовых телефонов;
3 - номера автомобилей;
4 - IP-адреса;
5 - URL.
Первый аргумент функции - диапазон ячеек с текстом, второй - порядковый номер из списка. Регулярные выражения зашиты в код функции. Можно их добавлять и расширять функционал.
Если у кого есть предложения по расширению списка извлекаемых конструкций - пишите.
Смотрю тут, на форуме, в последнее время активно обсуждаются регулярные выражения. Написал на досуге пользовательскую функцию "Поиск и извлечение уникальных значений с помощью регулярных выражений".
Что ищем и извлекаем:
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 |