Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Извлечь адрес электронной почты из текстовой строки
 
#1
15.10.2023 18:55:47
Использую данный код  с формулой  =ExtractEmailFun(A1), адреса извлекаются, но  так как их несколько не могу их потом разбить на столбцы. Как изменить код, чтобы адреса извлекались из текста, скажем через точку с запятой? буду очень признательна за ответ
Код
'извлечение адреса
Function ExtractEmailFun(extractStr As String) As String
'Update by extendoffice
Dim CharList As String
On Error Resume Next
CheckStr = "[A-Za-z0-9._-]"
outStr = ""
Index = 1
Do While True
    Index1 = VBA.InStr(Index, extractStr, "@")
    getStr = ""
    If Index1 > 0 Then
        For p = Index1 - 1 To 1 Step -1
            If Mid(extractStr, p, 1) Like CheckStr Then
                getStr = Mid(extractStr, p, 1) & getStr
            Else
                Exit For
            End If
        Next
        getStr = getStr & "@"
        For p = Index1 + 1 To Len(extractStr)
            If Mid(extractStr, p, 1) Like CheckStr Then
                getStr = getStr & Mid(extractStr, p, 1)
            Else
                Exit For
            End If
        Next
        Index = Index1 + 1
        If outStr = "" Then
            outStr = getStr
        Else
            outStr = outStr & Chr(10) & getStr
        End If
    Else
        Exit Do
    End If
Loop
ExtractEmailFun = outStr
End Function
Изменено: OL_IS - 15.10.2023 19:19:52
 
 
 
#2
15.10.2023 19:01:35
Код
Function em(s As String)
    Dim v
    Const EML_PTRN = "[A-Z0-9._%-]+@[A-Z0-9.-]+\.[A-Z]{2,4}"
    'https://www.regular-expressions.info/email.html  http://www.regular-expressions.info/regexbuddy/email.html

    With CreateObject("vbscript.regexp")
        .Pattern = EML_PTRN
        .Global = True
        .IgnoreCase = True
        Set v = .Execute(s)
    End With
    em = v(0).Value
End Function


P.S. писал когда ещё не было поста.
Этот код легко доработать.
Изменено: Hugo - 15.10.2023 19:05:50
 
 
 
#3
15.10.2023 19:05:54
Hugo, так формула не работает.
Я начинающая и сильно) мне все очень сложно дорабатывать, но я очень заинтересована научиться
Изменено: OL_IS - 15.10.2023 19:08:38
 
 
 
#4
15.10.2023 19:10:54
Код
Function emAll(s As String)
    Dim v, x$, m
    Const EML_PTRN = "[A-Z0-9._%-]+@[A-Z0-9.-]+\.[A-Z]{2,4}"
    'https://www.regular-expressions.info/email.html  http://www.regular-expressions.info/regexbuddy/email.html

    With CreateObject("vbscript.regexp")
        .Pattern = EML_PTRN
        .Global = True
        .IgnoreCase = True
        Set v = .Execute(s)
    End With
    For Each m In v
    x = x & ", " & m
    Next
    emAll = Mid(x, 3)
End Function
 
 
 
#5
15.10.2023 19:12:04
Цитата
OL_IS написал:
Я начинающая
тогда посоветую отредактировать первый пост - заключить код в теги.
 
 
 
#6
15.10.2023 19:20:45
Hugo, спасибо , исправилась) Но формула не работает с последним кодом все равно(  
 
 
 
#7
15.10.2023 19:24:08
Цитата
написал:
но  так как их несколько не могу их потом разбить на столбцы
я взял наобум 2 email и объединил в строку через пробел:
"info@akademia-excel.ru news@news.ozon.ru"
А как в строке один адрес от другого отделен в Вашем случае?
Всё сложное - не нужно. Всё нужное - просто /М. Т. Калашников/
 
 
 
#8
15.10.2023 19:30:35
Цитата
написал:
" info@akademia-excel.ru   news@news.ozon.ru "
news@news.ozon.ruinfo@akademia-excel.ru
у меня получается без пробела, но вроде как два абзаца в одной ячейке, но потом не могу их разбить по столбцам все равно. я думаю может через точку с запятой получится
Изменено: OL_IS - 15.10.2023 19:35:20
 
 
 
#9
15.10.2023 20:02:50
Цитата
OL_IS написал:
Но формула не работает с последним кодом все равно(
- докажете? У меня работают обе, только первая выводит один первый емайл, вторая все через запятую.
Дайте файл с несколькими емайлами (фейковыми!) и покажите что из чего пытаетесь получить.
Приложил мой файл, где всё работает как я представил задачу.
Изменено: Hugo - 15.10.2023 20:08:43
 
 
 
#10
15.10.2023 20:09:49
Hugo, вложила файлик для примера
я формулу другую вводила, сейчас с вашей попробую
Изменено: OL_IS - 15.10.2023 20:14:35
 
 
 
#11
15.10.2023 20:12:46
Можно в моём коде собирать не через ", ", а через "|" и тогда в финале
Код
emAll = Mid(x, 2)

Будет легко разбивать по столбцам.
Можно этот разделитель делать как аргумент/параметр, и тогда в финале брать его длину.
Изменено: Hugo - 15.10.2023 20:14:01
 
 
 
#12
15.10.2023 20:19:38
Hugo, Спасибо огромнейшее!!!!! все получилось как нужно
Только некоторые адреса в конце обрезаются несколько букв, уже после @, почему такое может быть??
и когда я удаляю пробел вот тут, то у первого адреса первая буква обрезается:
Код
x = x & "; " & m
Код
Function emAll(s As String)
    Dim v, x$, m
    Const EML_PTRN = "[A-Z0-9._%-]+@[A-Z0-9.-]+\.[A-Z]{2,4}"
    'Извлечь адрес электронной почты из текстовой строки

    With CreateObject("vbscript.regexp")
        .Pattern = EML_PTRN
        .Global = True
        .IgnoreCase = True
        Set v = .Execute(s)
    End With
    For Each m In v
    x = x & "; " & m
    Next
    emAll = Mid(x, 2)
End Function
Изменено: OL_IS - 15.10.2023 20:39:14
 
 
 
#13
15.10.2023 20:22:53
Цитата
OL_IS написал:
все получилось как нужно
- подозреваю что дубли не нужны. Можно доработать коллекцией или словарём.
P.S. доработал, разделитель и повторы опционально - если не указывать то будет | и без повторов.
Изменено: Hugo - 15.10.2023 20:38:32
 
 
 
#14
15.10.2023 22:20:42
Hugo, да, дубли просто отлично что нет)
а вот длинный домен обрезает , например: От: Владимир Иванов <v.ivanov@example.company> переносит как v.ivanov@example.comp
Изменено: OL_IS - 15.10.2023 22:30:18
 
 
 
#15
15.10.2023 22:24:45
Цитата
OL_IS написал:
а вот длинный домен обрезает
- не вникал, но наверное это не по стандарту, это уже не почта...
Но вот так например будет тянуть до 44 символов после точки вместо 4:
Код
Const EML_PTRN = "[A-Z0-9._%-]+@[A-Z0-9.-]+\.[A-Z]{2,44}"
 
 
 
#16
15.10.2023 22:31:18
Hugo, спасибо) попробую.
и я попробовала и все получилось!!!
Изменено: OL_IS - 15.10.2023 22:41:47
 
 
 
Страницы: 1
Наверх