Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Как из ячейки с текстом вырезать e-mail и перенести в соседнюю ячейку?
 
#1
30.07.2015 15:00:08
Есть текст такого вида:
"ООО 7-Я  PERSONAL-7YA@MAIL.RU"
или  
"ООО АВТОМАГ РЕСПУБЛИКАНСКАЯ 3 КОРП.5  AVTO_MAG.YAR@MAIL.RU"

Как вырезать электронную почту и вставить в соседнюю ячейку (справа например)?
 
 
 
#2
30.07.2015 15:24:39
вариант (100 скрытых столбцов для 100 символов исходного текста)
Удивление есть начало познания © Surprise me!
И да пребудет с нами сила ВПР.
 
 
 
#3
30.07.2015 15:27:08
без примера не знаю будет работать на различных текстах или нет допиливайте сами
Код
=ПСТР(A1;ПОИСК("/";ПОДСТАВИТЬ(A1;" ";"/";ДЛСТР(A1)-ДЛСТР(ПОДСТАВИТЬ(A1;" ";""))))+1;100)
Лень двигатель прогресса, доказано!!!
 
 
 
#4
30.07.2015 15:33:01
=СЖПРОБЕЛЫ(ПРАВБ(ПОДСТАВИТЬ(A2;" ";ПОВТОР(" ";400));400))
или
=СЖПРОБЕЛЫ(ПРАВБ(ПОДСТАВИТЬ(" "&ЛЕВБ(A2;ПОИСК("@";A2)-1);" ";ПОВТОР(" ";400));400)&ЛЕВБ(ПОДСТАВИТЬ(ПСТР(A2;ПОИСК("@";A2);400)&" ";" ";ПОВТОР(" ";400));400))
Цитата
Сергей написал:или нет
аналогично
Изменено: Catboyun - 30.07.2015 15:40:26
 
 
 
#5
30.07.2015 18:50:59
можете такой вариант попробовать
http://excelvba.ru/code/EmailList
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#6
30.07.2015 19:09:25
Кто подскажет, почему
Код
x = UBound(Split("ООО 7-Я PERSONAL-7YA@MAIL.RU"))
не видит второго (перед PERSONAL) пробела?
 
 
 
#7
30.07.2015 19:41:02
пробелы бывают разные
первый - обычный, chr(32)
второй - необычный (часто в 1С применяется), chr(160)
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#8
30.07.2015 19:50:44
Про 160 (неразрывный пробел) я в курсе, но чтобы он в такой строке оказался - даже и не подозревал ))
 
 
 
#9
31.07.2015 08:25:18
Вот опять - "вырезать и вставить". Это в принципе не может сделать ни одна формула, только макросом. Ну как вариант - две формулы в два доп.столбца...
А тем по копированию e-mail было навалом, и UDF есть как минимум парочка.
 
 
 
#10
03.08.2015 09:40:01
Не получается применить. Вот исходная база
 
 
 
#11
03.08.2015 09:49:40
что не получается ваших попыток даже не видно
Лень двигатель прогресса, доказано!!!
 
 
 
#12
03.08.2015 14:45:47
Вариант, однако... ;)
"Ctrl+S" - достойное завершение ваших гениальных мыслей!.. ;)
 
 
 
#13
03.08.2015 16:42:18
Хм. У меня почему-то пишет просто формулу, как в примере - не рассчитывает результат (на принтскрине ниже видно). Хотя в ваших файлах все считает.

А откуда взять "Extract hiperlinks"?

И еще - как сделать, чтобы в ячейке, откуда мы берем почту - ее не копировать, а вырезать, чтобы ее там не оставалось? Или создавать рядом новую ячейку, в которой не будет электронной почты



 
Изменено: Riplon - 03.08.2015 16:56:29
 
 
 
#14
03.08.2015 17:05:16
Так это тот редкий случай, когда и впрямь нужно вырезать :)
Я уже выше написал как. Дополню - если делать всё формулами, то заменяйте в исходной строке вытянутый емайл на пусто, ну и ещё поверх всему TRIM() не помешает.
 
 
 
#15
03.08.2015 17:12:19
Цитата
Riplon написал: ...И еще - как сделать...
Вам выдали немало вариантов, но вы САМИ пока ничего не предприняли, так может стоит вам просто заказать решение в "РАБОТЕ"?
ps И разберитесь со своими "непонятнокакими многострочными" данными - их стоит, имхо, тщательно причесать перед употреблением... ;)
"Ctrl+S" - достойное завершение ваших гениальных мыслей!.. ;)
 
 
 
#16
03.08.2015 17:16:26
Да, тут же выше всё уже есть.
 
 
 
#17
03.08.2015 17:42:41
Цитата
создавать рядом новую ячейку, в которой не будет электронной почты
UDF
Код
Function BezEmail(iCell As String)
  With CreateObject("vbscript.regexp")
   .Pattern = "[A-Z0-9._%-]+@[A-Z0-9.-]+\.[A-Z]{2,4}"
   .Global = True
   .IgnoreCase = True
  If .test(iCell) Then
    BezEmail = .Replace(iCell, "")
  Else
    BezEmail = iCell
  End If
 End With
End Function
 
 
 
#18
03.08.2015 20:05:17
У меня без регулярных выражений, попроще :)
Код
Function GetMail(From As String)
Dim arr
arr = Split(Application.WorksheetFunction.Trim(Replace(From, Chr(160), Chr(32))))
For Each a In arr
    If InStr(a, "@") <> 0 Then
        GetMail = a
        Exit Function
    End If
Next a
End Function
 
 
 
#19
03.08.2015 20:12:33
как человек в VBA плавающий выкладываю решение Kuzmich,  тама нет почты и МВТ, тама есть почта
Лень двигатель прогресса, доказано!!!
 
 
 
#20
03.08.2015 21:05:16
Цитата
тама нет почты
Вот почта
Код
Function Email(iCell As String)
    With CreateObject("vbscript.regexp")
        .Pattern = "[A-Z0-9._%-]+@[A-Z0-9.-]+\.[A-Z]{2,4}"
        .Global = True
        .IgnoreCase = True
        If .test(iCell) Then
          Email = .Execute(iCell)(0).Value
        Else
          Email = "Нет в строке электронного адреса"
        End If
    End With
End Function
 
 
 
Страницы: 1
Читают тему
Наверх